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;
2571 gfc_loopinfo loop, *ploop;
2572 gfc_actual_arglist *arg_array, *arg_mask;
2578 gfc_expr *arrayexpr;
2583 gfc_conv_intrinsic_funcall (se, expr);
2589 type = gfc_typenode_for_spec (&expr->ts);
2590 /* Initialize the result. */
2591 resvar = gfc_create_var (type, "val");
2596 scale = gfc_create_var (type, "scale");
2597 gfc_add_modify (&se->pre, scale,
2598 gfc_build_const (type, integer_one_node));
2599 tmp = gfc_build_const (type, integer_zero_node);
2601 else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
2602 tmp = gfc_build_const (type, integer_zero_node);
2603 else if (op == NE_EXPR)
2605 tmp = convert (type, boolean_false_node);
2606 else if (op == BIT_AND_EXPR)
2607 tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
2608 type, integer_one_node));
2610 tmp = gfc_build_const (type, integer_one_node);
2612 gfc_add_modify (&se->pre, resvar, tmp);
2614 arg_array = expr->value.function.actual;
2616 /* Walk the arguments. */
2617 arrayexpr = arg_array->expr;
2618 arrayss = gfc_walk_expr (arrayexpr);
2619 gcc_assert (arrayss != gfc_ss_terminator);
2621 if (op == NE_EXPR || norm2)
2622 /* PARITY and NORM2. */
2626 arg_mask = arg_array->next->next;
2627 gcc_assert (arg_mask != NULL);
2628 maskexpr = arg_mask->expr;
2631 if (maskexpr && maskexpr->rank > 0)
2633 maskss = gfc_walk_expr (maskexpr);
2634 gcc_assert (maskss != gfc_ss_terminator);
2639 /* Initialize the scalarizer. */
2640 gfc_init_loopinfo (&loop);
2641 gfc_add_ss_to_loop (&loop, arrayss);
2642 if (maskexpr && maskexpr->rank > 0)
2643 gfc_add_ss_to_loop (&loop, maskss);
2645 /* Initialize the loop. */
2646 gfc_conv_ss_startstride (&loop);
2647 gfc_conv_loop_setup (&loop, &expr->where);
2649 gfc_mark_ss_chain_used (arrayss, 1);
2650 if (maskexpr && maskexpr->rank > 0)
2651 gfc_mark_ss_chain_used (maskss, 1);
2654 /* Generate the loop body. */
2655 gfc_start_scalarized_body (ploop, &body);
2657 /* If we have a mask, only add this element if the mask is set. */
2658 if (maskexpr && maskexpr->rank > 0)
2660 gfc_init_se (&maskse, parent_se);
2661 gfc_copy_loopinfo_to_se (&maskse, ploop);
2663 gfc_conv_expr_val (&maskse, maskexpr);
2664 gfc_add_block_to_block (&body, &maskse.pre);
2666 gfc_start_block (&block);
2669 gfc_init_block (&block);
2671 /* Do the actual summation/product. */
2672 gfc_init_se (&arrayse, parent_se);
2673 gfc_copy_loopinfo_to_se (&arrayse, ploop);
2674 arrayse.ss = arrayss;
2675 gfc_conv_expr_val (&arrayse, arrayexpr);
2676 gfc_add_block_to_block (&block, &arrayse.pre);
2686 result = 1.0 + result * val * val;
2692 result += val * val;
2695 tree res1, res2, cond, absX, val;
2696 stmtblock_t ifblock1, ifblock2, ifblock3;
2698 gfc_init_block (&ifblock1);
2700 absX = gfc_create_var (type, "absX");
2701 gfc_add_modify (&ifblock1, absX,
2702 fold_build1_loc (input_location, ABS_EXPR, type,
2704 val = gfc_create_var (type, "val");
2705 gfc_add_expr_to_block (&ifblock1, val);
2707 gfc_init_block (&ifblock2);
2708 gfc_add_modify (&ifblock2, val,
2709 fold_build2_loc (input_location, RDIV_EXPR, type, scale,
2711 res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
2712 res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
2713 res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
2714 gfc_build_const (type, integer_one_node));
2715 gfc_add_modify (&ifblock2, resvar, res1);
2716 gfc_add_modify (&ifblock2, scale, absX);
2717 res1 = gfc_finish_block (&ifblock2);
2719 gfc_init_block (&ifblock3);
2720 gfc_add_modify (&ifblock3, val,
2721 fold_build2_loc (input_location, RDIV_EXPR, type, absX,
2723 res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
2724 res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
2725 gfc_add_modify (&ifblock3, resvar, res2);
2726 res2 = gfc_finish_block (&ifblock3);
2728 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2730 tmp = build3_v (COND_EXPR, cond, res1, res2);
2731 gfc_add_expr_to_block (&ifblock1, tmp);
2732 tmp = gfc_finish_block (&ifblock1);
2734 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2736 gfc_build_const (type, integer_zero_node));
2738 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2739 gfc_add_expr_to_block (&block, tmp);
2743 tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
2744 gfc_add_modify (&block, resvar, tmp);
2747 gfc_add_block_to_block (&block, &arrayse.post);
2749 if (maskexpr && maskexpr->rank > 0)
2751 /* We enclose the above in if (mask) {...} . */
2753 tmp = gfc_finish_block (&block);
2754 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2755 build_empty_stmt (input_location));
2758 tmp = gfc_finish_block (&block);
2759 gfc_add_expr_to_block (&body, tmp);
2761 gfc_trans_scalarizing_loops (ploop, &body);
2763 /* For a scalar mask, enclose the loop in an if statement. */
2764 if (maskexpr && maskexpr->rank == 0)
2766 gfc_init_se (&maskse, NULL);
2767 gfc_conv_expr_val (&maskse, maskexpr);
2768 gfc_init_block (&block);
2769 gfc_add_block_to_block (&block, &ploop->pre);
2770 gfc_add_block_to_block (&block, &ploop->post);
2771 tmp = gfc_finish_block (&block);
2773 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2774 build_empty_stmt (input_location));
2775 gfc_add_expr_to_block (&block, tmp);
2776 gfc_add_block_to_block (&se->pre, &block);
2780 gfc_add_block_to_block (&se->pre, &ploop->pre);
2781 gfc_add_block_to_block (&se->pre, &ploop->post);
2784 gfc_cleanup_loop (ploop);
2788 /* result = scale * sqrt(result). */
2790 sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
2791 resvar = build_call_expr_loc (input_location,
2793 resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
2800 /* Inline implementation of the dot_product intrinsic. This function
2801 is based on gfc_conv_intrinsic_arith (the previous function). */
2803 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2811 gfc_actual_arglist *actual;
2812 gfc_ss *arrayss1, *arrayss2;
2813 gfc_se arrayse1, arrayse2;
2814 gfc_expr *arrayexpr1, *arrayexpr2;
2816 type = gfc_typenode_for_spec (&expr->ts);
2818 /* Initialize the result. */
2819 resvar = gfc_create_var (type, "val");
2820 if (expr->ts.type == BT_LOGICAL)
2821 tmp = build_int_cst (type, 0);
2823 tmp = gfc_build_const (type, integer_zero_node);
2825 gfc_add_modify (&se->pre, resvar, tmp);
2827 /* Walk argument #1. */
2828 actual = expr->value.function.actual;
2829 arrayexpr1 = actual->expr;
2830 arrayss1 = gfc_walk_expr (arrayexpr1);
2831 gcc_assert (arrayss1 != gfc_ss_terminator);
2833 /* Walk argument #2. */
2834 actual = actual->next;
2835 arrayexpr2 = actual->expr;
2836 arrayss2 = gfc_walk_expr (arrayexpr2);
2837 gcc_assert (arrayss2 != gfc_ss_terminator);
2839 /* Initialize the scalarizer. */
2840 gfc_init_loopinfo (&loop);
2841 gfc_add_ss_to_loop (&loop, arrayss1);
2842 gfc_add_ss_to_loop (&loop, arrayss2);
2844 /* Initialize the loop. */
2845 gfc_conv_ss_startstride (&loop);
2846 gfc_conv_loop_setup (&loop, &expr->where);
2848 gfc_mark_ss_chain_used (arrayss1, 1);
2849 gfc_mark_ss_chain_used (arrayss2, 1);
2851 /* Generate the loop body. */
2852 gfc_start_scalarized_body (&loop, &body);
2853 gfc_init_block (&block);
2855 /* Make the tree expression for [conjg(]array1[)]. */
2856 gfc_init_se (&arrayse1, NULL);
2857 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2858 arrayse1.ss = arrayss1;
2859 gfc_conv_expr_val (&arrayse1, arrayexpr1);
2860 if (expr->ts.type == BT_COMPLEX)
2861 arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
2863 gfc_add_block_to_block (&block, &arrayse1.pre);
2865 /* Make the tree expression for array2. */
2866 gfc_init_se (&arrayse2, NULL);
2867 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2868 arrayse2.ss = arrayss2;
2869 gfc_conv_expr_val (&arrayse2, arrayexpr2);
2870 gfc_add_block_to_block (&block, &arrayse2.pre);
2872 /* Do the actual product and sum. */
2873 if (expr->ts.type == BT_LOGICAL)
2875 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
2876 arrayse1.expr, arrayse2.expr);
2877 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
2881 tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
2883 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
2885 gfc_add_modify (&block, resvar, tmp);
2887 /* Finish up the loop block and the loop. */
2888 tmp = gfc_finish_block (&block);
2889 gfc_add_expr_to_block (&body, tmp);
2891 gfc_trans_scalarizing_loops (&loop, &body);
2892 gfc_add_block_to_block (&se->pre, &loop.pre);
2893 gfc_add_block_to_block (&se->pre, &loop.post);
2894 gfc_cleanup_loop (&loop);
2900 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2901 we need to handle. For performance reasons we sometimes create two
2902 loops instead of one, where the second one is much simpler.
2903 Examples for minloc intrinsic:
2904 1) Result is an array, a call is generated
2905 2) Array mask is used and NaNs need to be supported:
2911 if (pos == 0) pos = S + (1 - from);
2912 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2919 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2923 3) NaNs need to be supported, but it is known at compile time or cheaply
2924 at runtime whether array is nonempty or not:
2929 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2932 if (from <= to) pos = 1;
2936 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2940 4) NaNs aren't supported, array mask is used:
2941 limit = infinities_supported ? Infinity : huge (limit);
2945 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2951 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2955 5) Same without array mask:
2956 limit = infinities_supported ? Infinity : huge (limit);
2957 pos = (from <= to) ? 1 : 0;
2960 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2963 For 3) and 5), if mask is scalar, this all goes into a conditional,
2964 setting pos = 0; in the else branch. */
2967 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
2971 stmtblock_t ifblock;
2972 stmtblock_t elseblock;
2983 gfc_actual_arglist *actual;
2988 gfc_expr *arrayexpr;
2995 gfc_conv_intrinsic_funcall (se, expr);
2999 /* Initialize the result. */
3000 pos = gfc_create_var (gfc_array_index_type, "pos");
3001 offset = gfc_create_var (gfc_array_index_type, "offset");
3002 type = gfc_typenode_for_spec (&expr->ts);
3004 /* Walk the arguments. */
3005 actual = expr->value.function.actual;
3006 arrayexpr = actual->expr;
3007 arrayss = gfc_walk_expr (arrayexpr);
3008 gcc_assert (arrayss != gfc_ss_terminator);
3010 actual = actual->next->next;
3011 gcc_assert (actual);
3012 maskexpr = actual->expr;
3014 if (maskexpr && maskexpr->rank != 0)
3016 maskss = gfc_walk_expr (maskexpr);
3017 gcc_assert (maskss != gfc_ss_terminator);
3022 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
3024 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
3026 nonempty = fold_build2_loc (input_location, GT_EXPR,
3027 boolean_type_node, nonempty,
3028 gfc_index_zero_node);
3033 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
3034 switch (arrayexpr->ts.type)
3037 tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
3041 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
3042 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
3043 arrayexpr->ts.kind);
3050 /* We start with the most negative possible value for MAXLOC, and the most
3051 positive possible value for MINLOC. The most negative possible value is
3052 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3053 possible value is HUGE in both cases. */
3055 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
3056 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
3057 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
3058 build_int_cst (type, 1));
3060 gfc_add_modify (&se->pre, limit, tmp);
3062 /* Initialize the scalarizer. */
3063 gfc_init_loopinfo (&loop);
3064 gfc_add_ss_to_loop (&loop, arrayss);
3066 gfc_add_ss_to_loop (&loop, maskss);
3068 /* Initialize the loop. */
3069 gfc_conv_ss_startstride (&loop);
3071 /* The code generated can have more than one loop in sequence (see the
3072 comment at the function header). This doesn't work well with the
3073 scalarizer, which changes arrays' offset when the scalarization loops
3074 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3075 are currently inlined in the scalar case only (for which loop is of rank
3076 one). As there is no dependency to care about in that case, there is no
3077 temporary, so that we can use the scalarizer temporary code to handle
3078 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3079 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3081 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3082 should eventually go away. We could either create two loops properly,
3083 or find another way to save/restore the array offsets between the two
3084 loops (without conflicting with temporary management), or use a single
3085 loop minmaxloc implementation. See PR 31067. */
3086 loop.temp_dim = loop.dimen;
3087 gfc_conv_loop_setup (&loop, &expr->where);
3089 gcc_assert (loop.dimen == 1);
3090 if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
3091 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3092 loop.from[0], loop.to[0]);
3096 /* Initialize the position to zero, following Fortran 2003. We are free
3097 to do this because Fortran 95 allows the result of an entirely false
3098 mask to be processor dependent. If we know at compile time the array
3099 is non-empty and no MASK is used, we can initialize to 1 to simplify
3101 if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
3102 gfc_add_modify (&loop.pre, pos,
3103 fold_build3_loc (input_location, COND_EXPR,
3104 gfc_array_index_type,
3105 nonempty, gfc_index_one_node,
3106 gfc_index_zero_node));
3109 gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
3110 lab1 = gfc_build_label_decl (NULL_TREE);
3111 TREE_USED (lab1) = 1;
3112 lab2 = gfc_build_label_decl (NULL_TREE);
3113 TREE_USED (lab2) = 1;
3116 /* An offset must be added to the loop
3117 counter to obtain the required position. */
3118 gcc_assert (loop.from[0]);
3120 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3121 gfc_index_one_node, loop.from[0]);
3122 gfc_add_modify (&loop.pre, offset, tmp);
3124 gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
3126 gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
3127 /* Generate the loop body. */
3128 gfc_start_scalarized_body (&loop, &body);
3130 /* If we have a mask, only check this element if the mask is set. */
3133 gfc_init_se (&maskse, NULL);
3134 gfc_copy_loopinfo_to_se (&maskse, &loop);
3136 gfc_conv_expr_val (&maskse, maskexpr);
3137 gfc_add_block_to_block (&body, &maskse.pre);
3139 gfc_start_block (&block);
3142 gfc_init_block (&block);
3144 /* Compare with the current limit. */
3145 gfc_init_se (&arrayse, NULL);
3146 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3147 arrayse.ss = arrayss;
3148 gfc_conv_expr_val (&arrayse, arrayexpr);
3149 gfc_add_block_to_block (&block, &arrayse.pre);
3151 /* We do the following if this is a more extreme value. */
3152 gfc_start_block (&ifblock);
3154 /* Assign the value to the limit... */
3155 gfc_add_modify (&ifblock, limit, arrayse.expr);
3157 if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
3159 stmtblock_t ifblock2;
3162 gfc_start_block (&ifblock2);
3163 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3164 loop.loopvar[0], offset);
3165 gfc_add_modify (&ifblock2, pos, tmp);
3166 ifbody2 = gfc_finish_block (&ifblock2);
3167 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pos,
3168 gfc_index_zero_node);
3169 tmp = build3_v (COND_EXPR, cond, ifbody2,
3170 build_empty_stmt (input_location));
3171 gfc_add_expr_to_block (&block, tmp);
3174 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3175 loop.loopvar[0], offset);
3176 gfc_add_modify (&ifblock, pos, tmp);
3179 gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
3181 ifbody = gfc_finish_block (&ifblock);
3183 if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
3186 cond = fold_build2_loc (input_location,
3187 op == GT_EXPR ? GE_EXPR : LE_EXPR,
3188 boolean_type_node, arrayse.expr, limit);
3190 cond = fold_build2_loc (input_location, op, boolean_type_node,
3191 arrayse.expr, limit);
3193 ifbody = build3_v (COND_EXPR, cond, ifbody,
3194 build_empty_stmt (input_location));
3196 gfc_add_expr_to_block (&block, ifbody);
3200 /* We enclose the above in if (mask) {...}. */
3201 tmp = gfc_finish_block (&block);
3203 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3204 build_empty_stmt (input_location));
3207 tmp = gfc_finish_block (&block);
3208 gfc_add_expr_to_block (&body, tmp);
3212 gfc_trans_scalarized_loop_boundary (&loop, &body);
3214 if (HONOR_NANS (DECL_MODE (limit)))
3216 if (nonempty != NULL)
3218 ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
3219 tmp = build3_v (COND_EXPR, nonempty, ifbody,
3220 build_empty_stmt (input_location));
3221 gfc_add_expr_to_block (&loop.code[0], tmp);
3225 gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
3226 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
3228 /* If we have a mask, only check this element if the mask is set. */
3231 gfc_init_se (&maskse, NULL);
3232 gfc_copy_loopinfo_to_se (&maskse, &loop);
3234 gfc_conv_expr_val (&maskse, maskexpr);
3235 gfc_add_block_to_block (&body, &maskse.pre);
3237 gfc_start_block (&block);
3240 gfc_init_block (&block);
3242 /* Compare with the current limit. */
3243 gfc_init_se (&arrayse, NULL);
3244 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3245 arrayse.ss = arrayss;
3246 gfc_conv_expr_val (&arrayse, arrayexpr);
3247 gfc_add_block_to_block (&block, &arrayse.pre);
3249 /* We do the following if this is a more extreme value. */
3250 gfc_start_block (&ifblock);
3252 /* Assign the value to the limit... */
3253 gfc_add_modify (&ifblock, limit, arrayse.expr);
3255 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3256 loop.loopvar[0], offset);
3257 gfc_add_modify (&ifblock, pos, tmp);
3259 ifbody = gfc_finish_block (&ifblock);
3261 cond = fold_build2_loc (input_location, op, boolean_type_node,
3262 arrayse.expr, limit);
3264 tmp = build3_v (COND_EXPR, cond, ifbody,
3265 build_empty_stmt (input_location));
3266 gfc_add_expr_to_block (&block, tmp);
3270 /* We enclose the above in if (mask) {...}. */
3271 tmp = gfc_finish_block (&block);
3273 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3274 build_empty_stmt (input_location));
3277 tmp = gfc_finish_block (&block);
3278 gfc_add_expr_to_block (&body, tmp);
3279 /* Avoid initializing loopvar[0] again, it should be left where
3280 it finished by the first loop. */
3281 loop.from[0] = loop.loopvar[0];
3284 gfc_trans_scalarizing_loops (&loop, &body);
3287 gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
3289 /* For a scalar mask, enclose the loop in an if statement. */
3290 if (maskexpr && maskss == NULL)
3292 gfc_init_se (&maskse, NULL);
3293 gfc_conv_expr_val (&maskse, maskexpr);
3294 gfc_init_block (&block);
3295 gfc_add_block_to_block (&block, &loop.pre);
3296 gfc_add_block_to_block (&block, &loop.post);
3297 tmp = gfc_finish_block (&block);
3299 /* For the else part of the scalar mask, just initialize
3300 the pos variable the same way as above. */
3302 gfc_init_block (&elseblock);
3303 gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
3304 elsetmp = gfc_finish_block (&elseblock);
3306 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
3307 gfc_add_expr_to_block (&block, tmp);
3308 gfc_add_block_to_block (&se->pre, &block);
3312 gfc_add_block_to_block (&se->pre, &loop.pre);
3313 gfc_add_block_to_block (&se->pre, &loop.post);
3315 gfc_cleanup_loop (&loop);
3317 se->expr = convert (type, pos);
3320 /* Emit code for minval or maxval intrinsic. There are many different cases
3321 we need to handle. For performance reasons we sometimes create two
3322 loops instead of one, where the second one is much simpler.
3323 Examples for minval intrinsic:
3324 1) Result is an array, a call is generated
3325 2) Array mask is used and NaNs need to be supported, rank 1:
3330 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
3333 limit = nonempty ? NaN : huge (limit);
3335 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
3336 3) NaNs need to be supported, but it is known at compile time or cheaply
3337 at runtime whether array is nonempty or not, rank 1:
3340 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
3341 limit = (from <= to) ? NaN : huge (limit);
3343 while (S <= to) { limit = min (a[S], limit); S++; }
3344 4) Array mask is used and NaNs need to be supported, rank > 1:
3353 if (fast) limit = min (a[S1][S2], limit);
3356 if (a[S1][S2] <= limit) {
3367 limit = nonempty ? NaN : huge (limit);
3368 5) NaNs need to be supported, but it is known at compile time or cheaply
3369 at runtime whether array is nonempty or not, rank > 1:
3376 if (fast) limit = min (a[S1][S2], limit);
3378 if (a[S1][S2] <= limit) {
3388 limit = (nonempty_array) ? NaN : huge (limit);
3389 6) NaNs aren't supported, but infinities are. Array mask is used:
3394 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
3397 limit = nonempty ? limit : huge (limit);
3398 7) Same without array mask:
3401 while (S <= to) { limit = min (a[S], limit); S++; }
3402 limit = (from <= to) ? limit : huge (limit);
3403 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
3404 limit = huge (limit);
3406 while (S <= to) { limit = min (a[S], limit); S++); }
3408 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
3409 with array mask instead).
3410 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
3411 setting limit = huge (limit); in the else branch. */
3414 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
3424 tree huge_cst = NULL, nan_cst = NULL;
3426 stmtblock_t block, block2;
3428 gfc_actual_arglist *actual;
3433 gfc_expr *arrayexpr;
3439 gfc_conv_intrinsic_funcall (se, expr);
3443 type = gfc_typenode_for_spec (&expr->ts);
3444 /* Initialize the result. */
3445 limit = gfc_create_var (type, "limit");
3446 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
3447 switch (expr->ts.type)
3450 huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
3452 if (HONOR_INFINITIES (DECL_MODE (limit)))
3454 REAL_VALUE_TYPE real;
3456 tmp = build_real (type, real);
3460 if (HONOR_NANS (DECL_MODE (limit)))
3462 REAL_VALUE_TYPE real;
3463 real_nan (&real, "", 1, DECL_MODE (limit));
3464 nan_cst = build_real (type, real);
3469 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
3476 /* We start with the most negative possible value for MAXVAL, and the most
3477 positive possible value for MINVAL. The most negative possible value is
3478 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3479 possible value is HUGE in both cases. */
3482 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
3484 huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
3485 TREE_TYPE (huge_cst), huge_cst);
3488 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
3489 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
3490 tmp, build_int_cst (type, 1));
3492 gfc_add_modify (&se->pre, limit, tmp);
3494 /* Walk the arguments. */
3495 actual = expr->value.function.actual;
3496 arrayexpr = actual->expr;
3497 arrayss = gfc_walk_expr (arrayexpr);
3498 gcc_assert (arrayss != gfc_ss_terminator);
3500 actual = actual->next->next;
3501 gcc_assert (actual);
3502 maskexpr = actual->expr;
3504 if (maskexpr && maskexpr->rank != 0)
3506 maskss = gfc_walk_expr (maskexpr);
3507 gcc_assert (maskss != gfc_ss_terminator);
3512 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
3514 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
3516 nonempty = fold_build2_loc (input_location, GT_EXPR,
3517 boolean_type_node, nonempty,
3518 gfc_index_zero_node);
3523 /* Initialize the scalarizer. */
3524 gfc_init_loopinfo (&loop);
3525 gfc_add_ss_to_loop (&loop, arrayss);
3527 gfc_add_ss_to_loop (&loop, maskss);
3529 /* Initialize the loop. */
3530 gfc_conv_ss_startstride (&loop);
3532 /* The code generated can have more than one loop in sequence (see the
3533 comment at the function header). This doesn't work well with the
3534 scalarizer, which changes arrays' offset when the scalarization loops
3535 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
3536 are currently inlined in the scalar case only. As there is no dependency
3537 to care about in that case, there is no temporary, so that we can use the
3538 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
3539 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
3540 gfc_trans_scalarized_loop_boundary even later to restore offset.
3541 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
3542 should eventually go away. We could either create two loops properly,
3543 or find another way to save/restore the array offsets between the two
3544 loops (without conflicting with temporary management), or use a single
3545 loop minmaxval implementation. See PR 31067. */
3546 loop.temp_dim = loop.dimen;
3547 gfc_conv_loop_setup (&loop, &expr->where);
3549 if (nonempty == NULL && maskss == NULL
3550 && loop.dimen == 1 && loop.from[0] && loop.to[0])
3551 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3552 loop.from[0], loop.to[0]);
3553 nonempty_var = NULL;
3554 if (nonempty == NULL
3555 && (HONOR_INFINITIES (DECL_MODE (limit))
3556 || HONOR_NANS (DECL_MODE (limit))))
3558 nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
3559 gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
3560 nonempty = nonempty_var;
3564 if (HONOR_NANS (DECL_MODE (limit)))
3566 if (loop.dimen == 1)
3568 lab = gfc_build_label_decl (NULL_TREE);
3569 TREE_USED (lab) = 1;
3573 fast = gfc_create_var (boolean_type_node, "fast");
3574 gfc_add_modify (&se->pre, fast, boolean_false_node);
3578 gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
3580 gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
3581 /* Generate the loop body. */
3582 gfc_start_scalarized_body (&loop, &body);
3584 /* If we have a mask, only add this element if the mask is set. */
3587 gfc_init_se (&maskse, NULL);
3588 gfc_copy_loopinfo_to_se (&maskse, &loop);
3590 gfc_conv_expr_val (&maskse, maskexpr);
3591 gfc_add_block_to_block (&body, &maskse.pre);
3593 gfc_start_block (&block);
3596 gfc_init_block (&block);
3598 /* Compare with the current limit. */
3599 gfc_init_se (&arrayse, NULL);
3600 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3601 arrayse.ss = arrayss;
3602 gfc_conv_expr_val (&arrayse, arrayexpr);
3603 gfc_add_block_to_block (&block, &arrayse.pre);
3605 gfc_init_block (&block2);
3608 gfc_add_modify (&block2, nonempty_var, boolean_true_node);
3610 if (HONOR_NANS (DECL_MODE (limit)))
3612 tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
3613 boolean_type_node, arrayse.expr, limit);
3615 ifbody = build1_v (GOTO_EXPR, lab);
3618 stmtblock_t ifblock;
3620 gfc_init_block (&ifblock);
3621 gfc_add_modify (&ifblock, limit, arrayse.expr);
3622 gfc_add_modify (&ifblock, fast, boolean_true_node);
3623 ifbody = gfc_finish_block (&ifblock);
3625 tmp = build3_v (COND_EXPR, tmp, ifbody,
3626 build_empty_stmt (input_location));
3627 gfc_add_expr_to_block (&block2, tmp);
3631 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3633 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3635 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3636 arrayse.expr, limit);
3637 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3638 tmp = build3_v (COND_EXPR, tmp, ifbody,
3639 build_empty_stmt (input_location));
3640 gfc_add_expr_to_block (&block2, tmp);
3644 tmp = fold_build2_loc (input_location,
3645 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3646 type, arrayse.expr, limit);
3647 gfc_add_modify (&block2, limit, tmp);
3653 tree elsebody = gfc_finish_block (&block2);
3655 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3657 if (HONOR_NANS (DECL_MODE (limit))
3658 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3660 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3661 arrayse.expr, limit);
3662 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3663 ifbody = build3_v (COND_EXPR, tmp, ifbody,
3664 build_empty_stmt (input_location));
3668 tmp = fold_build2_loc (input_location,
3669 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3670 type, arrayse.expr, limit);
3671 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
3673 tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
3674 gfc_add_expr_to_block (&block, tmp);
3677 gfc_add_block_to_block (&block, &block2);
3679 gfc_add_block_to_block (&block, &arrayse.post);
3681 tmp = gfc_finish_block (&block);
3683 /* We enclose the above in if (mask) {...}. */
3684 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3685 build_empty_stmt (input_location));
3686 gfc_add_expr_to_block (&body, tmp);
3690 gfc_trans_scalarized_loop_boundary (&loop, &body);
3692 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
3694 gfc_add_modify (&loop.code[0], limit, tmp);
3695 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
3697 /* If we have a mask, only add this element if the mask is set. */
3700 gfc_init_se (&maskse, NULL);
3701 gfc_copy_loopinfo_to_se (&maskse, &loop);
3703 gfc_conv_expr_val (&maskse, maskexpr);
3704 gfc_add_block_to_block (&body, &maskse.pre);
3706 gfc_start_block (&block);
3709 gfc_init_block (&block);
3711 /* Compare with the current limit. */
3712 gfc_init_se (&arrayse, NULL);
3713 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3714 arrayse.ss = arrayss;
3715 gfc_conv_expr_val (&arrayse, arrayexpr);
3716 gfc_add_block_to_block (&block, &arrayse.pre);
3718 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3720 if (HONOR_NANS (DECL_MODE (limit))
3721 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3723 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3724 arrayse.expr, limit);
3725 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3726 tmp = build3_v (COND_EXPR, tmp, ifbody,
3727 build_empty_stmt (input_location));
3728 gfc_add_expr_to_block (&block, tmp);
3732 tmp = fold_build2_loc (input_location,
3733 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3734 type, arrayse.expr, limit);
3735 gfc_add_modify (&block, limit, tmp);
3738 gfc_add_block_to_block (&block, &arrayse.post);
3740 tmp = gfc_finish_block (&block);
3742 /* We enclose the above in if (mask) {...}. */
3743 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3744 build_empty_stmt (input_location));
3745 gfc_add_expr_to_block (&body, tmp);
3746 /* Avoid initializing loopvar[0] again, it should be left where
3747 it finished by the first loop. */
3748 loop.from[0] = loop.loopvar[0];
3750 gfc_trans_scalarizing_loops (&loop, &body);
3754 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
3756 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
3757 tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
3759 gfc_add_expr_to_block (&loop.pre, tmp);
3761 else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
3763 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
3765 gfc_add_modify (&loop.pre, limit, tmp);
3768 /* For a scalar mask, enclose the loop in an if statement. */
3769 if (maskexpr && maskss == NULL)
3773 gfc_init_se (&maskse, NULL);
3774 gfc_conv_expr_val (&maskse, maskexpr);
3775 gfc_init_block (&block);
3776 gfc_add_block_to_block (&block, &loop.pre);
3777 gfc_add_block_to_block (&block, &loop.post);
3778 tmp = gfc_finish_block (&block);
3780 if (HONOR_INFINITIES (DECL_MODE (limit)))
3781 else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
3783 else_stmt = build_empty_stmt (input_location);
3784 tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
3785 gfc_add_expr_to_block (&block, tmp);
3786 gfc_add_block_to_block (&se->pre, &block);
3790 gfc_add_block_to_block (&se->pre, &loop.pre);
3791 gfc_add_block_to_block (&se->pre, &loop.post);
3794 gfc_cleanup_loop (&loop);
3799 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3801 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
3807 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3808 type = TREE_TYPE (args[0]);
3810 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3811 build_int_cst (type, 1), args[1]);
3812 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
3813 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
3814 build_int_cst (type, 0));
3815 type = gfc_typenode_for_spec (&expr->ts);
3816 se->expr = convert (type, tmp);
3820 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
3822 gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
3826 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3828 /* Convert both arguments to the unsigned type of the same size. */
3829 args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
3830 args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
3832 /* If they have unequal type size, convert to the larger one. */
3833 if (TYPE_PRECISION (TREE_TYPE (args[0]))
3834 > TYPE_PRECISION (TREE_TYPE (args[1])))
3835 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
3836 else if (TYPE_PRECISION (TREE_TYPE (args[1]))
3837 > TYPE_PRECISION (TREE_TYPE (args[0])))
3838 args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
3840 /* Now, we compare them. */
3841 se->expr = fold_build2_loc (input_location, op, boolean_type_node,
3846 /* Generate code to perform the specified operation. */
3848 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
3852 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3853 se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
3859 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
3863 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3864 se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
3865 TREE_TYPE (arg), arg);
3868 /* Set or clear a single bit. */
3870 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
3877 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3878 type = TREE_TYPE (args[0]);
3880 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3881 build_int_cst (type, 1), args[1]);
3887 tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
3889 se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
3892 /* Extract a sequence of bits.
3893 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3895 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
3902 gfc_conv_intrinsic_function_args (se, expr, args, 3);
3903 type = TREE_TYPE (args[0]);
3905 mask = build_int_cst (type, -1);
3906 mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
3907 mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
3909 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
3911 se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
3915 gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
3918 tree args[2], type, num_bits, cond;
3920 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3922 args[0] = gfc_evaluate_now (args[0], &se->pre);
3923 args[1] = gfc_evaluate_now (args[1], &se->pre);
3924 type = TREE_TYPE (args[0]);
3927 args[0] = fold_convert (unsigned_type_for (type), args[0]);
3929 gcc_assert (right_shift);
3931 se->expr = fold_build2_loc (input_location,
3932 right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
3933 TREE_TYPE (args[0]), args[0], args[1]);
3936 se->expr = fold_convert (type, se->expr);
3938 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3939 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3941 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
3942 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3945 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
3946 build_int_cst (type, 0), se->expr);
3949 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
3951 : ((shift >= 0) ? i << shift : i >> -shift)
3952 where all shifts are logical shifts. */
3954 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
3966 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3968 args[0] = gfc_evaluate_now (args[0], &se->pre);
3969 args[1] = gfc_evaluate_now (args[1], &se->pre);
3971 type = TREE_TYPE (args[0]);
3972 utype = unsigned_type_for (type);
3974 width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
3977 /* Left shift if positive. */
3978 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
3980 /* Right shift if negative.
3981 We convert to an unsigned type because we want a logical shift.
3982 The standard doesn't define the case of shifting negative
3983 numbers, and we try to be compatible with other compilers, most
3984 notably g77, here. */
3985 rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
3986 utype, convert (utype, args[0]), width));
3988 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, args[1],
3989 build_int_cst (TREE_TYPE (args[1]), 0));
3990 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
3992 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3993 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3995 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
3996 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, width,
3998 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
3999 build_int_cst (type, 0), tmp);
4003 /* Circular shift. AKA rotate or barrel shift. */
4006 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
4014 unsigned int num_args;
4016 num_args = gfc_intrinsic_argument_list_length (expr);
4017 args = XALLOCAVEC (tree, num_args);
4019 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
4023 /* Use a library function for the 3 parameter version. */
4024 tree int4type = gfc_get_int_type (4);
4026 type = TREE_TYPE (args[0]);
4027 /* We convert the first argument to at least 4 bytes, and
4028 convert back afterwards. This removes the need for library
4029 functions for all argument sizes, and function will be
4030 aligned to at least 32 bits, so there's no loss. */
4031 if (expr->ts.kind < 4)
4032 args[0] = convert (int4type, args[0]);
4034 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4035 need loads of library functions. They cannot have values >
4036 BIT_SIZE (I) so the conversion is safe. */
4037 args[1] = convert (int4type, args[1]);
4038 args[2] = convert (int4type, args[2]);
4040 switch (expr->ts.kind)
4045 tmp = gfor_fndecl_math_ishftc4;
4048 tmp = gfor_fndecl_math_ishftc8;
4051 tmp = gfor_fndecl_math_ishftc16;
4056 se->expr = build_call_expr_loc (input_location,
4057 tmp, 3, args[0], args[1], args[2]);
4058 /* Convert the result back to the original type, if we extended
4059 the first argument's width above. */
4060 if (expr->ts.kind < 4)
4061 se->expr = convert (type, se->expr);
4065 type = TREE_TYPE (args[0]);
4067 /* Evaluate arguments only once. */
4068 args[0] = gfc_evaluate_now (args[0], &se->pre);
4069 args[1] = gfc_evaluate_now (args[1], &se->pre);
4071 /* Rotate left if positive. */
4072 lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
4074 /* Rotate right if negative. */
4075 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
4077 rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
4079 zero = build_int_cst (TREE_TYPE (args[1]), 0);
4080 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, args[1],
4082 rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
4084 /* Do nothing if shift == 0. */
4085 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, args[1],
4087 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
4092 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4093 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4095 The conditional expression is necessary because the result of LEADZ(0)
4096 is defined, but the result of __builtin_clz(0) is undefined for most
4099 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4100 difference in bit size between the argument of LEADZ and the C int. */
4103 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
4115 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4116 argsize = TYPE_PRECISION (TREE_TYPE (arg));
4118 /* Which variant of __builtin_clz* should we call? */
4119 if (argsize <= INT_TYPE_SIZE)
4121 arg_type = unsigned_type_node;
4122 func = builtin_decl_explicit (BUILT_IN_CLZ);
4124 else if (argsize <= LONG_TYPE_SIZE)
4126 arg_type = long_unsigned_type_node;
4127 func = builtin_decl_explicit (BUILT_IN_CLZL);
4129 else if (argsize <= LONG_LONG_TYPE_SIZE)
4131 arg_type = long_long_unsigned_type_node;
4132 func = builtin_decl_explicit (BUILT_IN_CLZLL);
4136 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
4137 arg_type = gfc_build_uint_type (argsize);
4141 /* Convert the actual argument twice: first, to the unsigned type of the
4142 same size; then, to the proper argument type for the built-in
4143 function. But the return type is of the default INTEGER kind. */
4144 arg = fold_convert (gfc_build_uint_type (argsize), arg);
4145 arg = fold_convert (arg_type, arg);
4146 arg = gfc_evaluate_now (arg, &se->pre);
4147 result_type = gfc_get_int_type (gfc_default_integer_kind);
4149 /* Compute LEADZ for the case i .ne. 0. */
4152 s = TYPE_PRECISION (arg_type) - argsize;
4153 tmp = fold_convert (result_type,
4154 build_call_expr_loc (input_location, func,
4156 leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
4157 tmp, build_int_cst (result_type, s));
4161 /* We end up here if the argument type is larger than 'long long'.
4162 We generate this code:
4164 if (x & (ULL_MAX << ULL_SIZE) != 0)
4165 return clzll ((unsigned long long) (x >> ULLSIZE));
4167 return ULL_SIZE + clzll ((unsigned long long) x);
4168 where ULL_MAX is the largest value that a ULL_MAX can hold
4169 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4170 is the bit-size of the long long type (64 in this example). */
4171 tree ullsize, ullmax, tmp1, tmp2, btmp;
4173 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
4174 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
4175 long_long_unsigned_type_node,
4176 build_int_cst (long_long_unsigned_type_node,
4179 cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
4180 fold_convert (arg_type, ullmax), ullsize);
4181 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
4183 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4184 cond, build_int_cst (arg_type, 0));
4186 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
4188 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
4189 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
4190 tmp1 = fold_convert (result_type,
4191 build_call_expr_loc (input_location, btmp, 1, tmp1));
4193 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
4194 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
4195 tmp2 = fold_convert (result_type,
4196 build_call_expr_loc (input_location, btmp, 1, tmp2));
4197 tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
4200 leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
4204 /* Build BIT_SIZE. */
4205 bit_size = build_int_cst (result_type, argsize);
4207 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4208 arg, build_int_cst (arg_type, 0));
4209 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
4214 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4216 The conditional expression is necessary because the result of TRAILZ(0)
4217 is defined, but the result of __builtin_ctz(0) is undefined for most
4221 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
4232 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4233 argsize = TYPE_PRECISION (TREE_TYPE (arg));
4235 /* Which variant of __builtin_ctz* should we call? */
4236 if (argsize <= INT_TYPE_SIZE)
4238 arg_type = unsigned_type_node;
4239 func = builtin_decl_explicit (BUILT_IN_CTZ);
4241 else if (argsize <= LONG_TYPE_SIZE)
4243 arg_type = long_unsigned_type_node;
4244 func = builtin_decl_explicit (BUILT_IN_CTZL);
4246 else if (argsize <= LONG_LONG_TYPE_SIZE)
4248 arg_type = long_long_unsigned_type_node;
4249 func = builtin_decl_explicit (BUILT_IN_CTZLL);
4253 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
4254 arg_type = gfc_build_uint_type (argsize);
4258 /* Convert the actual argument twice: first, to the unsigned type of the
4259 same size; then, to the proper argument type for the built-in
4260 function. But the return type is of the default INTEGER kind. */
4261 arg = fold_convert (gfc_build_uint_type (argsize), arg);
4262 arg = fold_convert (arg_type, arg);
4263 arg = gfc_evaluate_now (arg, &se->pre);
4264 result_type = gfc_get_int_type (gfc_default_integer_kind);
4266 /* Compute TRAILZ for the case i .ne. 0. */
4268 trailz = fold_convert (result_type, build_call_expr_loc (input_location,
4272 /* We end up here if the argument type is larger than 'long long'.
4273 We generate this code:
4275 if ((x & ULL_MAX) == 0)
4276 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
4278 return ctzll ((unsigned long long) x);
4280 where ULL_MAX is the largest value that a ULL_MAX can hold
4281 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4282 is the bit-size of the long long type (64 in this example). */
4283 tree ullsize, ullmax, tmp1, tmp2, btmp;
4285 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
4286 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
4287 long_long_unsigned_type_node,
4288 build_int_cst (long_long_unsigned_type_node, 0));
4290 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
4291 fold_convert (arg_type, ullmax));
4292 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, cond,
4293 build_int_cst (arg_type, 0));
4295 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
4297 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
4298 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
4299 tmp1 = fold_convert (result_type,
4300 build_call_expr_loc (input_location, btmp, 1, tmp1));
4301 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
4304 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
4305 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
4306 tmp2 = fold_convert (result_type,
4307 build_call_expr_loc (input_location, btmp, 1, tmp2));
4309 trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
4313 /* Build BIT_SIZE. */
4314 bit_size = build_int_cst (result_type, argsize);
4316 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4317 arg, build_int_cst (arg_type, 0));
4318 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
4322 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
4323 for types larger than "long long", we call the long long built-in for
4324 the lower and higher bits and combine the result. */
4327 gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
4335 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4336 argsize = TYPE_PRECISION (TREE_TYPE (arg));
4337 result_type = gfc_get_int_type (gfc_default_integer_kind);
4339 /* Which variant of the builtin should we call? */
4340 if (argsize <= INT_TYPE_SIZE)
4342 arg_type = unsigned_type_node;
4343 func = builtin_decl_explicit (parity
4345 : BUILT_IN_POPCOUNT);
4347 else if (argsize <= LONG_TYPE_SIZE)
4349 arg_type = long_unsigned_type_node;
4350 func = builtin_decl_explicit (parity
4352 : BUILT_IN_POPCOUNTL);
4354 else if (argsize <= LONG_LONG_TYPE_SIZE)
4356 arg_type = long_long_unsigned_type_node;
4357 func = builtin_decl_explicit (parity
4359 : BUILT_IN_POPCOUNTLL);
4363 /* Our argument type is larger than 'long long', which mean none
4364 of the POPCOUNT builtins covers it. We thus call the 'long long'
4365 variant multiple times, and add the results. */
4366 tree utype, arg2, call1, call2;
4368 /* For now, we only cover the case where argsize is twice as large
4370 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
4372 func = builtin_decl_explicit (parity
4374 : BUILT_IN_POPCOUNTLL);
4376 /* Convert it to an integer, and store into a variable. */
4377 utype = gfc_build_uint_type (argsize);
4378 arg = fold_convert (utype, arg);
4379 arg = gfc_evaluate_now (arg, &se->pre);
4381 /* Call the builtin twice. */
4382 call1 = build_call_expr_loc (input_location, func, 1,
4383 fold_convert (long_long_unsigned_type_node,
4386 arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
4387 build_int_cst (utype, LONG_LONG_TYPE_SIZE));
4388 call2 = build_call_expr_loc (input_location, func, 1,
4389 fold_convert (long_long_unsigned_type_node,
4392 /* Combine the results. */
4394 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type,
4397 se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type,
4403 /* Convert the actual argument twice: first, to the unsigned type of the
4404 same size; then, to the proper argument type for the built-in
4406 arg = fold_convert (gfc_build_uint_type (argsize), arg);
4407 arg = fold_convert (arg_type, arg);
4409 se->expr = fold_convert (result_type,
4410 build_call_expr_loc (input_location, func, 1, arg));
4414 /* Process an intrinsic with unspecified argument-types that has an optional
4415 argument (which could be of type character), e.g. EOSHIFT. For those, we
4416 need to append the string length of the optional argument if it is not
4417 present and the type is really character.
4418 primary specifies the position (starting at 1) of the non-optional argument
4419 specifying the type and optional gives the position of the optional
4420 argument in the arglist. */
4423 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
4424 unsigned primary, unsigned optional)
4426 gfc_actual_arglist* prim_arg;
4427 gfc_actual_arglist* opt_arg;
4429 gfc_actual_arglist* arg;
4431 VEC(tree,gc) *append_args;
4433 /* Find the two arguments given as position. */
4437 for (arg = expr->value.function.actual; arg; arg = arg->next)
4441 if (cur_pos == primary)
4443 if (cur_pos == optional)
4446 if (cur_pos >= primary && cur_pos >= optional)
4449 gcc_assert (prim_arg);
4450 gcc_assert (prim_arg->expr);
4451 gcc_assert (opt_arg);
4453 /* If we do have type CHARACTER and the optional argument is really absent,
4454 append a dummy 0 as string length. */
4456 if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
4460 dummy = build_int_cst (gfc_charlen_type_node, 0);
4461 append_args = VEC_alloc (tree, gc, 1);
4462 VEC_quick_push (tree, append_args, dummy);
4465 /* Build the call itself. */
4466 sym = gfc_get_symbol_for_expr (expr);
4467 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4473 /* The length of a character string. */
4475 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
4485 gcc_assert (!se->ss);
4487 arg = expr->value.function.actual->expr;
4489 type = gfc_typenode_for_spec (&expr->ts);
4490 switch (arg->expr_type)
4493 len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
4497 /* Obtain the string length from the function used by
4498 trans-array.c(gfc_trans_array_constructor). */
4500 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
4504 if (arg->ref == NULL
4505 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
4507 /* This doesn't catch all cases.
4508 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
4509 and the surrounding thread. */
4510 sym = arg->symtree->n.sym;
4511 decl = gfc_get_symbol_decl (sym);
4512 if (decl == current_function_decl && sym->attr.function
4513 && (sym->result == sym))
4514 decl = gfc_get_fake_result_decl (sym, 0);
4516 len = sym->ts.u.cl->backend_decl;
4521 /* Otherwise fall through. */
4524 /* Anybody stupid enough to do this deserves inefficient code. */
4525 ss = gfc_walk_expr (arg);
4526 gfc_init_se (&argse, se);
4527 if (ss == gfc_ss_terminator)
4528 gfc_conv_expr (&argse, arg);
4530 gfc_conv_expr_descriptor (&argse, arg, ss);
4531 gfc_add_block_to_block (&se->pre, &argse.pre);
4532 gfc_add_block_to_block (&se->post, &argse.post);
4533 len = argse.string_length;
4536 se->expr = convert (type, len);
4539 /* The length of a character string not including trailing blanks. */
4541 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
4543 int kind = expr->value.function.actual->expr->ts.kind;
4544 tree args[2], type, fndecl;
4546 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4547 type = gfc_typenode_for_spec (&expr->ts);
4550 fndecl = gfor_fndecl_string_len_trim;
4552 fndecl = gfor_fndecl_string_len_trim_char4;
4556 se->expr = build_call_expr_loc (input_location,
4557 fndecl, 2, args[0], args[1]);
4558 se->expr = convert (type, se->expr);
4562 /* Returns the starting position of a substring within a string. */
4565 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
4568 tree logical4_type_node = gfc_get_logical_type (4);
4572 unsigned int num_args;
4574 args = XALLOCAVEC (tree, 5);
4576 /* Get number of arguments; characters count double due to the
4577 string length argument. Kind= is not passed to the library
4578 and thus ignored. */
4579 if (expr->value.function.actual->next->next->expr == NULL)
4584 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
4585 type = gfc_typenode_for_spec (&expr->ts);
4588 args[4] = build_int_cst (logical4_type_node, 0);
4590 args[4] = convert (logical4_type_node, args[4]);
4592 fndecl = build_addr (function, current_function_decl);
4593 se->expr = build_call_array_loc (input_location,
4594 TREE_TYPE (TREE_TYPE (function)), fndecl,
4596 se->expr = convert (type, se->expr);
4600 /* The ascii value for a single character. */
4602 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
4604 tree args[2], type, pchartype;
4606 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4607 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
4608 pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
4609 args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
4610 type = gfc_typenode_for_spec (&expr->ts);
4612 se->expr = build_fold_indirect_ref_loc (input_location,
4614 se->expr = convert (type, se->expr);
4618 /* Intrinsic ISNAN calls __builtin_isnan. */
4621 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
4625 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4626 se->expr = build_call_expr_loc (input_location,
4627 builtin_decl_explicit (BUILT_IN_ISNAN),
4629 STRIP_TYPE_NOPS (se->expr);
4630 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4634 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
4635 their argument against a constant integer value. */
4638 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
4642 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4643 se->expr = fold_build2_loc (input_location, EQ_EXPR,
4644 gfc_typenode_for_spec (&expr->ts),
4645 arg, build_int_cst (TREE_TYPE (arg), value));
4650 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
4653 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
4661 unsigned int num_args;
4663 num_args = gfc_intrinsic_argument_list_length (expr);
4664 args = XALLOCAVEC (tree, num_args);
4666 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
4667 if (expr->ts.type != BT_CHARACTER)
4675 /* We do the same as in the non-character case, but the argument
4676 list is different because of the string length arguments. We
4677 also have to set the string length for the result. */
4684 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
4686 se->string_length = len;
4688 type = TREE_TYPE (tsource);
4689 se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
4690 fold_convert (type, fsource));
4694 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
4697 gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
4699 tree args[3], mask, type;
4701 gfc_conv_intrinsic_function_args (se, expr, args, 3);
4702 mask = gfc_evaluate_now (args[2], &se->pre);
4704 type = TREE_TYPE (args[0]);
4705 gcc_assert (TREE_TYPE (args[1]) == type);
4706 gcc_assert (TREE_TYPE (mask) == type);
4708 args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
4709 args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
4710 fold_build1_loc (input_location, BIT_NOT_EXPR,
4712 se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
4717 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
4718 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
4721 gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
4723 tree arg, allones, type, utype, res, cond, bitsize;
4726 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4727 arg = gfc_evaluate_now (arg, &se->pre);
4729 type = gfc_get_int_type (expr->ts.kind);
4730 utype = unsigned_type_for (type);
4732 i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
4733 bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
4735 allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
4736 build_int_cst (utype, 0));
4740 /* Left-justified mask. */
4741 res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
4743 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
4744 fold_convert (utype, res));
4746 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
4747 smaller than type width. */
4748 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
4749 build_int_cst (TREE_TYPE (arg), 0));
4750 res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
4751 build_int_cst (utype, 0), res);
4755 /* Right-justified mask. */
4756 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
4757 fold_convert (utype, arg));
4758 res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
4760 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
4761 strictly smaller than type width. */
4762 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4764 res = fold_build3_loc (input_location, COND_EXPR, utype,
4765 cond, allones, res);
4768 se->expr = fold_convert (type, res);
4772 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
4774 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
4776 tree arg, type, tmp, frexp;
4778 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4780 type = gfc_typenode_for_spec (&expr->ts);
4781 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4782 tmp = gfc_create_var (integer_type_node, NULL);
4783 se->expr = build_call_expr_loc (input_location, frexp, 2,
4784 fold_convert (type, arg),
4785 gfc_build_addr_expr (NULL_TREE, tmp));
4786 se->expr = fold_convert (type, se->expr);
4790 /* NEAREST (s, dir) is translated into
4791 tmp = copysign (HUGE_VAL, dir);
4792 return nextafter (s, tmp);
4795 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
4797 tree args[2], type, tmp, nextafter, copysign, huge_val;
4799 nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
4800 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
4802 type = gfc_typenode_for_spec (&expr->ts);
4803 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4805 huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
4806 tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
4807 fold_convert (type, args[1]));
4808 se->expr = build_call_expr_loc (input_location, nextafter, 2,
4809 fold_convert (type, args[0]), tmp);
4810 se->expr = fold_convert (type, se->expr);
4814 /* SPACING (s) is translated into
4822 e = MAX_EXPR (e, emin);
4823 res = scalbn (1., e);
4827 where prec is the precision of s, gfc_real_kinds[k].digits,
4828 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
4829 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
4832 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
4834 tree arg, type, prec, emin, tiny, res, e;
4835 tree cond, tmp, frexp, scalbn;
4839 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
4840 prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
4841 emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
4842 tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
4844 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4845 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4847 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4848 arg = gfc_evaluate_now (arg, &se->pre);
4850 type = gfc_typenode_for_spec (&expr->ts);
4851 e = gfc_create_var (integer_type_node, NULL);
4852 res = gfc_create_var (type, NULL);
4855 /* Build the block for s /= 0. */
4856 gfc_start_block (&block);
4857 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
4858 gfc_build_addr_expr (NULL_TREE, e));
4859 gfc_add_expr_to_block (&block, tmp);
4861 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
4863 gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
4864 integer_type_node, tmp, emin));
4866 tmp = build_call_expr_loc (input_location, scalbn, 2,
4867 build_real_from_int_cst (type, integer_one_node), e);
4868 gfc_add_modify (&block, res, tmp);
4870 /* Finish by building the IF statement. */
4871 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
4872 build_real_from_int_cst (type, integer_zero_node));
4873 tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
4874 gfc_finish_block (&block));
4876 gfc_add_expr_to_block (&se->pre, tmp);
4881 /* RRSPACING (s) is translated into
4888 x = scalbn (x, precision - e);
4892 where precision is gfc_real_kinds[k].digits. */
4895 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
4897 tree arg, type, e, x, cond, stmt, tmp, frexp, scalbn, fabs;
4901 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
4902 prec = gfc_real_kinds[k].digits;
4904 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4905 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4906 fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
4908 type = gfc_typenode_for_spec (&expr->ts);
4909 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4910 arg = gfc_evaluate_now (arg, &se->pre);
4912 e = gfc_create_var (integer_type_node, NULL);
4913 x = gfc_create_var (type, NULL);
4914 gfc_add_modify (&se->pre, x,
4915 build_call_expr_loc (input_location, fabs, 1, arg));
4918 gfc_start_block (&block);
4919 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
4920 gfc_build_addr_expr (NULL_TREE, e));
4921 gfc_add_expr_to_block (&block, tmp);
4923 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4924 build_int_cst (integer_type_node, prec), e);
4925 tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
4926 gfc_add_modify (&block, x, tmp);
4927 stmt = gfc_finish_block (&block);
4929 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, x,
4930 build_real_from_int_cst (type, integer_zero_node));
4931 tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
4932 gfc_add_expr_to_block (&se->pre, tmp);
4934 se->expr = fold_convert (type, x);
4938 /* SCALE (s, i) is translated into scalbn (s, i). */
4940 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
4942 tree args[2], type, scalbn;
4944 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4946 type = gfc_typenode_for_spec (&expr->ts);
4947 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4948 se->expr = build_call_expr_loc (input_location, scalbn, 2,
4949 fold_convert (type, args[0]),
4950 fold_convert (integer_type_node, args[1]));
4951 se->expr = fold_convert (type, se->expr);
4955 /* SET_EXPONENT (s, i) is translated into
4956 scalbn (frexp (s, &dummy_int), i). */
4958 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
4960 tree args[2], type, tmp, frexp, scalbn;
4962 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4963 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4965 type = gfc_typenode_for_spec (&expr->ts);
4966 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4968 tmp = gfc_create_var (integer_type_node, NULL);
4969 tmp = build_call_expr_loc (input_location, frexp, 2,
4970 fold_convert (type, args[0]),
4971 gfc_build_addr_expr (NULL_TREE, tmp));
4972 se->expr = build_call_expr_loc (input_location, scalbn, 2, tmp,
4973 fold_convert (integer_type_node, args[1]));
4974 se->expr = fold_convert (type, se->expr);
4979 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
4981 gfc_actual_arglist *actual;
4989 gfc_init_se (&argse, NULL);
4990 actual = expr->value.function.actual;
4992 ss = gfc_walk_expr (actual->expr);
4993 gcc_assert (ss != gfc_ss_terminator);
4994 argse.want_pointer = 1;
4995 argse.data_not_needed = 1;
4996 gfc_conv_expr_descriptor (&argse, actual->expr, ss);
4997 gfc_add_block_to_block (&se->pre, &argse.pre);
4998 gfc_add_block_to_block (&se->post, &argse.post);
4999 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
5001 /* Build the call to size0. */
5002 fncall0 = build_call_expr_loc (input_location,
5003 gfor_fndecl_size0, 1, arg1);
5005 actual = actual->next;
5009 gfc_init_se (&argse, NULL);
5010 gfc_conv_expr_type (&argse, actual->expr,
5011 gfc_array_index_type);
5012 gfc_add_block_to_block (&se->pre, &argse.pre);
5014 /* Unusually, for an intrinsic, size does not exclude
5015 an optional arg2, so we must test for it. */
5016 if (actual->expr->expr_type == EXPR_VARIABLE
5017 && actual->expr->symtree->n.sym->attr.dummy
5018 && actual->expr->symtree->n.sym->attr.optional)
5021 /* Build the call to size1. */
5022 fncall1 = build_call_expr_loc (input_location,
5023 gfor_fndecl_size1, 2,
5026 gfc_init_se (&argse, NULL);
5027 argse.want_pointer = 1;
5028 argse.data_not_needed = 1;
5029 gfc_conv_expr (&argse, actual->expr);
5030 gfc_add_block_to_block (&se->pre, &argse.pre);
5031 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5032 argse.expr, null_pointer_node);
5033 tmp = gfc_evaluate_now (tmp, &se->pre);
5034 se->expr = fold_build3_loc (input_location, COND_EXPR,
5035 pvoid_type_node, tmp, fncall1, fncall0);
5039 se->expr = NULL_TREE;
5040 argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
5041 gfc_array_index_type,
5042 argse.expr, gfc_index_one_node);
5045 else if (expr->value.function.actual->expr->rank == 1)
5047 argse.expr = gfc_index_zero_node;
5048 se->expr = NULL_TREE;
5053 if (se->expr == NULL_TREE)
5055 tree ubound, lbound;
5057 arg1 = build_fold_indirect_ref_loc (input_location,
5059 ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
5060 lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
5061 se->expr = fold_build2_loc (input_location, MINUS_EXPR,
5062 gfc_array_index_type, ubound, lbound);
5063 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
5064 gfc_array_index_type,
5065 se->expr, gfc_index_one_node);
5066 se->expr = fold_build2_loc (input_location, MAX_EXPR,
5067 gfc_array_index_type, se->expr,
5068 gfc_index_zero_node);
5071 type = gfc_typenode_for_spec (&expr->ts);
5072 se->expr = convert (type, se->expr);
5076 /* Helper function to compute the size of a character variable,
5077 excluding the terminating null characters. The result has
5078 gfc_array_index_type type. */
5081 size_of_string_in_bytes (int kind, tree string_length)
5084 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
5086 bytesize = build_int_cst (gfc_array_index_type,
5087 gfc_character_kinds[i].bit_size / 8);
5089 return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5091 fold_convert (gfc_array_index_type, string_length));
5096 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
5108 arg = expr->value.function.actual->expr;
5110 gfc_init_se (&argse, NULL);
5111 ss = gfc_walk_expr (arg);
5113 if (ss == gfc_ss_terminator)
5115 if (arg->ts.type == BT_CLASS)
5116 gfc_add_data_component (arg);
5118 gfc_conv_expr_reference (&argse, arg);
5120 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5123 /* Obtain the source word length. */
5124 if (arg->ts.type == BT_CHARACTER)
5125 se->expr = size_of_string_in_bytes (arg->ts.kind,
5126 argse.string_length);
5128 se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
5132 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
5133 argse.want_pointer = 0;
5134 gfc_conv_expr_descriptor (&argse, arg, ss);
5135 type = gfc_get_element_type (TREE_TYPE (argse.expr));
5137 /* Obtain the argument's word length. */
5138 if (arg->ts.type == BT_CHARACTER)
5139 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
5141 tmp = fold_convert (gfc_array_index_type,
5142 size_in_bytes (type));
5143 gfc_add_modify (&argse.pre, source_bytes, tmp);
5145 /* Obtain the size of the array in bytes. */
5146 for (n = 0; n < arg->rank; n++)
5149 idx = gfc_rank_cst[n];
5150 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
5151 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
5152 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5153 gfc_array_index_type, upper, lower);
5154 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5155 gfc_array_index_type, tmp, gfc_index_one_node);
5156 tmp = fold_build2_loc (input_location, MULT_EXPR,
5157 gfc_array_index_type, tmp, source_bytes);
5158 gfc_add_modify (&argse.pre, source_bytes, tmp);
5160 se->expr = source_bytes;
5163 gfc_add_block_to_block (&se->pre, &argse.pre);
5168 gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
5173 tree type, result_type, tmp;
5175 arg = expr->value.function.actual->expr;
5176 gfc_init_se (&eight, NULL);
5177 gfc_conv_expr (&eight, gfc_get_int_expr (expr->ts.kind, NULL, 8));
5179 gfc_init_se (&argse, NULL);
5180 ss = gfc_walk_expr (arg);
5181 result_type = gfc_get_int_type (expr->ts.kind);
5183 if (ss == gfc_ss_terminator)
5185 if (arg->ts.type == BT_CLASS)
5187 gfc_add_vptr_component (arg);
5188 gfc_add_size_component (arg);
5189 gfc_conv_expr (&argse, arg);
5190 tmp = fold_convert (result_type, argse.expr);
5194 gfc_conv_expr_reference (&argse, arg);
5195 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5200 argse.want_pointer = 0;
5201 gfc_conv_expr_descriptor (&argse, arg, ss);
5202 type = gfc_get_element_type (TREE_TYPE (argse.expr));
5205 /* Obtain the argument's word length. */
5206 if (arg->ts.type == BT_CHARACTER)
5207 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
5209 tmp = fold_convert (result_type, size_in_bytes (type));
5212 se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
5214 gfc_add_block_to_block (&se->pre, &argse.pre);
5218 /* Intrinsic string comparison functions. */
5221 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
5225 gfc_conv_intrinsic_function_args (se, expr, args, 4);
5228 = gfc_build_compare_string (args[0], args[1], args[2], args[3],
5229 expr->value.function.actual->expr->ts.kind,
5231 se->expr = fold_build2_loc (input_location, op,
5232 gfc_typenode_for_spec (&expr->ts), se->expr,
5233 build_int_cst (TREE_TYPE (se->expr), 0));
5236 /* Generate a call to the adjustl/adjustr library function. */
5238 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
5246 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
5249 type = TREE_TYPE (args[2]);
5250 var = gfc_conv_string_tmp (se, type, len);
5253 tmp = build_call_expr_loc (input_location,
5254 fndecl, 3, args[0], args[1], args[2]);
5255 gfc_add_expr_to_block (&se->pre, tmp);
5257 se->string_length = len;
5261 /* Generate code for the TRANSFER intrinsic:
5263 DEST = TRANSFER (SOURCE, MOLD)
5265 typeof<DEST> = typeof<MOLD>
5270 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
5272 typeof<DEST> = typeof<MOLD>
5274 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
5275 sizeof (DEST(0) * SIZE). */
5277 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
5293 gfc_actual_arglist *arg;
5296 gfc_array_info *info;
5303 info = &se->ss->info->data.array;
5305 /* Convert SOURCE. The output from this stage is:-
5306 source_bytes = length of the source in bytes
5307 source = pointer to the source data. */
5308 arg = expr->value.function.actual;
5310 /* Ensure double transfer through LOGICAL preserves all
5312 if (arg->expr->expr_type == EXPR_FUNCTION
5313 && arg->expr->value.function.esym == NULL
5314 && arg->expr->value.function.isym != NULL
5315 && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
5316 && arg->expr->ts.type == BT_LOGICAL
5317 && expr->ts.type != arg->expr->ts.type)
5318 arg->expr->value.function.name = "__transfer_in_transfer";
5320 gfc_init_se (&argse, NULL);
5321 ss = gfc_walk_expr (arg->expr);
5323 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
5325 /* Obtain the pointer to source and the length of source in bytes. */
5326 if (ss == gfc_ss_terminator)
5328 gfc_conv_expr_reference (&argse, arg->expr);
5329 source = argse.expr;
5331 source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5334 /* Obtain the source word length. */
5335 if (arg->expr->ts.type == BT_CHARACTER)
5336 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
5337 argse.string_length);
5339 tmp = fold_convert (gfc_array_index_type,
5340 size_in_bytes (source_type));
5344 argse.want_pointer = 0;
5345 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
5346 source = gfc_conv_descriptor_data_get (argse.expr);
5347 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
5349 /* Repack the source if not a full variable array. */
5350 if (arg->expr->expr_type == EXPR_VARIABLE
5351 && arg->expr->ref->u.ar.type != AR_FULL)
5353 tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
5355 if (gfc_option.warn_array_temp)
5356 gfc_warning ("Creating array temporary at %L", &expr->where);
5358 source = build_call_expr_loc (input_location,
5359 gfor_fndecl_in_pack, 1, tmp);
5360 source = gfc_evaluate_now (source, &argse.pre);
5362 /* Free the temporary. */
5363 gfc_start_block (&block);
5364 tmp = gfc_call_free (convert (pvoid_type_node, source));
5365 gfc_add_expr_to_block (&block, tmp);
5366 stmt = gfc_finish_block (&block);
5368 /* Clean up if it was repacked. */
5369 gfc_init_block (&block);
5370 tmp = gfc_conv_array_data (argse.expr);
5371 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5373 tmp = build3_v (COND_EXPR, tmp, stmt,
5374 build_empty_stmt (input_location));
5375 gfc_add_expr_to_block (&block, tmp);
5376 gfc_add_block_to_block (&block, &se->post);
5377 gfc_init_block (&se->post);
5378 gfc_add_block_to_block (&se->post, &block);
5381 /* Obtain the source word length. */
5382 if (arg->expr->ts.type == BT_CHARACTER)
5383 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
5384 argse.string_length);
5386 tmp = fold_convert (gfc_array_index_type,
5387 size_in_bytes (source_type));
5389 /* Obtain the size of the array in bytes. */
5390 extent = gfc_create_var (gfc_array_index_type, NULL);
5391 for (n = 0; n < arg->expr->rank; n++)
5394 idx = gfc_rank_cst[n];
5395 gfc_add_modify (&argse.pre, source_bytes, tmp);
5396 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
5397 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
5398 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5399 gfc_array_index_type, upper, lower);
5400 gfc_add_modify (&argse.pre, extent, tmp);
5401 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5402 gfc_array_index_type, extent,
5403 gfc_index_one_node);
5404 tmp = fold_build2_loc (input_location, MULT_EXPR,
5405 gfc_array_index_type, tmp, source_bytes);
5409 gfc_add_modify (&argse.pre, source_bytes, tmp);
5410 gfc_add_block_to_block (&se->pre, &argse.pre);
5411 gfc_add_block_to_block (&se->post, &argse.post);
5413 /* Now convert MOLD. The outputs are:
5414 mold_type = the TREE type of MOLD
5415 dest_word_len = destination word length in bytes. */
5418 gfc_init_se (&argse, NULL);
5419 ss = gfc_walk_expr (arg->expr);
5421 scalar_mold = arg->expr->rank == 0;
5423 if (ss == gfc_ss_terminator)
5425 gfc_conv_expr_reference (&argse, arg->expr);
5426 mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5431 gfc_init_se (&argse, NULL);
5432 argse.want_pointer = 0;
5433 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
5434 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
5437 gfc_add_block_to_block (&se->pre, &argse.pre);
5438 gfc_add_block_to_block (&se->post, &argse.post);
5440 if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
5442 /* If this TRANSFER is nested in another TRANSFER, use a type
5443 that preserves all bits. */
5444 if (arg->expr->ts.type == BT_LOGICAL)
5445 mold_type = gfc_get_int_type (arg->expr->ts.kind);
5448 if (arg->expr->ts.type == BT_CHARACTER)
5450 tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
5451 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
5454 tmp = fold_convert (gfc_array_index_type,
5455 size_in_bytes (mold_type));
5457 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
5458 gfc_add_modify (&se->pre, dest_word_len, tmp);
5460 /* Finally convert SIZE, if it is present. */
5462 size_words = gfc_create_var (gfc_array_index_type, NULL);
5466 gfc_init_se (&argse, NULL);
5467 gfc_conv_expr_reference (&argse, arg->expr);
5468 tmp = convert (gfc_array_index_type,
5469 build_fold_indirect_ref_loc (input_location,
5471 gfc_add_block_to_block (&se->pre, &argse.pre);
5472 gfc_add_block_to_block (&se->post, &argse.post);
5477 /* Separate array and scalar results. */
5478 if (scalar_mold && tmp == NULL_TREE)
5479 goto scalar_transfer;
5481 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
5482 if (tmp != NULL_TREE)
5483 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5484 tmp, dest_word_len);
5488 gfc_add_modify (&se->pre, size_bytes, tmp);
5489 gfc_add_modify (&se->pre, size_words,
5490 fold_build2_loc (input_location, CEIL_DIV_EXPR,
5491 gfc_array_index_type,
5492 size_bytes, dest_word_len));
5494 /* Evaluate the bounds of the result. If the loop range exists, we have
5495 to check if it is too large. If so, we modify loop->to be consistent
5496 with min(size, size(source)). Otherwise, size is made consistent with
5497 the loop range, so that the right number of bytes is transferred.*/
5498 n = se->loop->order[0];
5499 if (se->loop->to[n] != NULL_TREE)
5501 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5502 se->loop->to[n], se->loop->from[n]);
5503 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5504 tmp, gfc_index_one_node);
5505 tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
5507 gfc_add_modify (&se->pre, size_words, tmp);
5508 gfc_add_modify (&se->pre, size_bytes,
5509 fold_build2_loc (input_location, MULT_EXPR,
5510 gfc_array_index_type,
5511 size_words, dest_word_len));
5512 upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5513 size_words, se->loop->from[n]);
5514 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5515 upper, gfc_index_one_node);
5519 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5520 size_words, gfc_index_one_node);
5521 se->loop->from[n] = gfc_index_zero_node;
5524 se->loop->to[n] = upper;
5526 /* Build a destination descriptor, using the pointer, source, as the
5528 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
5529 NULL_TREE, false, true, false, &expr->where);
5531 /* Cast the pointer to the result. */
5532 tmp = gfc_conv_descriptor_data_get (info->descriptor);
5533 tmp = fold_convert (pvoid_type_node, tmp);
5535 /* Use memcpy to do the transfer. */
5536 tmp = build_call_expr_loc (input_location,
5537 builtin_decl_explicit (BUILT_IN_MEMCPY),
5540 fold_convert (pvoid_type_node, source),
5541 fold_build2_loc (input_location, MIN_EXPR,
5542 gfc_array_index_type,
5543 size_bytes, source_bytes));
5544 gfc_add_expr_to_block (&se->pre, tmp);
5546 se->expr = info->descriptor;
5547 if (expr->ts.type == BT_CHARACTER)
5548 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
5552 /* Deal with scalar results. */
5554 extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
5555 dest_word_len, source_bytes);
5556 extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5557 extent, gfc_index_zero_node);
5559 if (expr->ts.type == BT_CHARACTER)
5564 ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
5565 tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
5568 /* If source is longer than the destination, use a pointer to
5569 the source directly. */
5570 gfc_init_block (&block);
5571 gfc_add_modify (&block, tmpdecl, ptr);
5572 direct = gfc_finish_block (&block);
5574 /* Otherwise, allocate a string with the length of the destination
5575 and copy the source into it. */
5576 gfc_init_block (&block);
5577 tmp = gfc_get_pchar_type (expr->ts.kind);
5578 tmp = gfc_call_malloc (&block, tmp, dest_word_len);
5579 gfc_add_modify (&block, tmpdecl,
5580 fold_convert (TREE_TYPE (ptr), tmp));
5581 tmp = build_call_expr_loc (input_location,
5582 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
5583 fold_convert (pvoid_type_node, tmpdecl),
5584 fold_convert (pvoid_type_node, ptr),
5586 gfc_add_expr_to_block (&block, tmp);
5587 indirect = gfc_finish_block (&block);
5589 /* Wrap it up with the condition. */
5590 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
5591 dest_word_len, source_bytes);
5592 tmp = build3_v (COND_EXPR, tmp, direct, indirect);
5593 gfc_add_expr_to_block (&se->pre, tmp);
5596 se->string_length = dest_word_len;
5600 tmpdecl = gfc_create_var (mold_type, "transfer");
5602 ptr = convert (build_pointer_type (mold_type), source);
5604 /* Use memcpy to do the transfer. */
5605 tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
5606 tmp = build_call_expr_loc (input_location,
5607 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
5608 fold_convert (pvoid_type_node, tmp),
5609 fold_convert (pvoid_type_node, ptr),
5611 gfc_add_expr_to_block (&se->pre, tmp);
5618 /* Generate code for the ALLOCATED intrinsic.
5619 Generate inline code that directly check the address of the argument. */
5622 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
5624 gfc_actual_arglist *arg1;
5629 gfc_init_se (&arg1se, NULL);
5630 arg1 = expr->value.function.actual;
5631 ss1 = gfc_walk_expr (arg1->expr);
5633 if (ss1 == gfc_ss_terminator)
5635 /* Allocatable scalar. */
5636 arg1se.want_pointer = 1;
5637 if (arg1->expr->ts.type == BT_CLASS)
5638 gfc_add_data_component (arg1->expr);
5639 gfc_conv_expr (&arg1se, arg1->expr);
5644 /* Allocatable array. */
5645 arg1se.descriptor_only = 1;
5646 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
5647 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
5650 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
5651 fold_convert (TREE_TYPE (tmp), null_pointer_node));
5652 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
5656 /* Generate code for the ASSOCIATED intrinsic.
5657 If both POINTER and TARGET are arrays, generate a call to library function
5658 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
5659 In other cases, generate inline code that directly compare the address of
5660 POINTER with the address of TARGET. */
5663 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
5665 gfc_actual_arglist *arg1;
5666 gfc_actual_arglist *arg2;
5671 tree nonzero_charlen;
5672 tree nonzero_arraylen;
5675 gfc_init_se (&arg1se, NULL);
5676 gfc_init_se (&arg2se, NULL);
5677 arg1 = expr->value.function.actual;
5678 if (arg1->expr->ts.type == BT_CLASS)
5679 gfc_add_data_component (arg1->expr);
5681 ss1 = gfc_walk_expr (arg1->expr);
5685 /* No optional target. */
5686 if (ss1 == gfc_ss_terminator)
5688 /* A pointer to a scalar. */
5689 arg1se.want_pointer = 1;
5690 gfc_conv_expr (&arg1se, arg1->expr);
5695 /* A pointer to an array. */
5696 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
5697 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
5699 gfc_add_block_to_block (&se->pre, &arg1se.pre);
5700 gfc_add_block_to_block (&se->post, &arg1se.post);
5701 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2,
5702 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
5707 /* An optional target. */
5708 if (arg2->expr->ts.type == BT_CLASS)
5709 gfc_add_data_component (arg2->expr);
5710 ss2 = gfc_walk_expr (arg2->expr);
5712 nonzero_charlen = NULL_TREE;
5713 if (arg1->expr->ts.type == BT_CHARACTER)
5714 nonzero_charlen = fold_build2_loc (input_location, NE_EXPR,
5716 arg1->expr->ts.u.cl->backend_decl,
5719 if (ss1 == gfc_ss_terminator)
5721 /* A pointer to a scalar. */
5722 gcc_assert (ss2 == gfc_ss_terminator);
5723 arg1se.want_pointer = 1;
5724 gfc_conv_expr (&arg1se, arg1->expr);
5725 arg2se.want_pointer = 1;
5726 gfc_conv_expr (&arg2se, arg2->expr);
5727 gfc_add_block_to_block (&se->pre, &arg1se.pre);
5728 gfc_add_block_to_block (&se->post, &arg1se.post);
5729 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5730 arg1se.expr, arg2se.expr);
5731 tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5732 arg1se.expr, null_pointer_node);
5733 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5734 boolean_type_node, tmp, tmp2);
5738 /* An array pointer of zero length is not associated if target is
5740 arg1se.descriptor_only = 1;
5741 gfc_conv_expr_lhs (&arg1se, arg1->expr);
5742 tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
5743 gfc_rank_cst[arg1->expr->rank - 1]);
5744 nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
5745 boolean_type_node, tmp,
5746 build_int_cst (TREE_TYPE (tmp), 0));
5748 /* A pointer to an array, call library function _gfor_associated. */
5749 gcc_assert (ss2 != gfc_ss_terminator);
5750 arg1se.want_pointer = 1;
5751 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
5753 arg2se.want_pointer = 1;
5754 gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
5755 gfc_add_block_to_block (&se->pre, &arg2se.pre);
5756 gfc_add_block_to_block (&se->post, &arg2se.post);
5757 se->expr = build_call_expr_loc (input_location,
5758 gfor_fndecl_associated, 2,
5759 arg1se.expr, arg2se.expr);
5760 se->expr = convert (boolean_type_node, se->expr);
5761 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5762 boolean_type_node, se->expr,
5766 /* If target is present zero character length pointers cannot
5768 if (nonzero_charlen != NULL_TREE)
5769 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5771 se->expr, nonzero_charlen);
5774 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
5778 /* Generate code for the SAME_TYPE_AS intrinsic.
5779 Generate inline code that directly checks the vindices. */
5782 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
5788 gfc_init_se (&se1, NULL);
5789 gfc_init_se (&se2, NULL);
5791 a = expr->value.function.actual->expr;
5792 b = expr->value.function.actual->next->expr;
5794 if (a->ts.type == BT_CLASS)
5796 gfc_add_vptr_component (a);
5797 gfc_add_hash_component (a);
5799 else if (a->ts.type == BT_DERIVED)
5800 a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5801 a->ts.u.derived->hash_value);
5803 if (b->ts.type == BT_CLASS)
5805 gfc_add_vptr_component (b);
5806 gfc_add_hash_component (b);
5808 else if (b->ts.type == BT_DERIVED)
5809 b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5810 b->ts.u.derived->hash_value);
5812 gfc_conv_expr (&se1, a);
5813 gfc_conv_expr (&se2, b);
5815 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5816 se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
5817 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
5821 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
5824 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
5828 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5829 se->expr = build_call_expr_loc (input_location,
5830 gfor_fndecl_sc_kind, 2, args[0], args[1]);
5831 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
5835 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
5838 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
5842 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5844 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
5845 type = gfc_get_int_type (4);
5846 arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
5848 /* Convert it to the required type. */
5849 type = gfc_typenode_for_spec (&expr->ts);
5850 se->expr = build_call_expr_loc (input_location,
5851 gfor_fndecl_si_kind, 1, arg);
5852 se->expr = fold_convert (type, se->expr);
5856 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
5859 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
5861 gfc_actual_arglist *actual;
5864 VEC(tree,gc) *args = NULL;
5866 for (actual = expr->value.function.actual; actual; actual = actual->next)
5868 gfc_init_se (&argse, se);
5870 /* Pass a NULL pointer for an absent arg. */
5871 if (actual->expr == NULL)
5872 argse.expr = null_pointer_node;
5878 if (actual->expr->ts.kind != gfc_c_int_kind)
5880 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
5881 ts.type = BT_INTEGER;
5882 ts.kind = gfc_c_int_kind;
5883 gfc_convert_type (actual->expr, &ts, 2);
5885 gfc_conv_expr_reference (&argse, actual->expr);
5888 gfc_add_block_to_block (&se->pre, &argse.pre);
5889 gfc_add_block_to_block (&se->post, &argse.post);
5890 VEC_safe_push (tree, gc, args, argse.expr);
5893 /* Convert it to the required type. */
5894 type = gfc_typenode_for_spec (&expr->ts);
5895 se->expr = build_call_expr_loc_vec (input_location,
5896 gfor_fndecl_sr_kind, args);
5897 se->expr = fold_convert (type, se->expr);
5901 /* Generate code for TRIM (A) intrinsic function. */
5904 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
5914 unsigned int num_args;
5916 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
5917 args = XALLOCAVEC (tree, num_args);
5919 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
5920 addr = gfc_build_addr_expr (ppvoid_type_node, var);
5921 len = gfc_create_var (gfc_charlen_type_node, "len");
5923 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
5924 args[0] = gfc_build_addr_expr (NULL_TREE, len);
5927 if (expr->ts.kind == 1)
5928 function = gfor_fndecl_string_trim;
5929 else if (expr->ts.kind == 4)
5930 function = gfor_fndecl_string_trim_char4;
5934 fndecl = build_addr (function, current_function_decl);
5935 tmp = build_call_array_loc (input_location,
5936 TREE_TYPE (TREE_TYPE (function)), fndecl,
5938 gfc_add_expr_to_block (&se->pre, tmp);
5940 /* Free the temporary afterwards, if necessary. */
5941 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
5942 len, build_int_cst (TREE_TYPE (len), 0));
5943 tmp = gfc_call_free (var);
5944 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
5945 gfc_add_expr_to_block (&se->post, tmp);
5948 se->string_length = len;
5952 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
5955 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
5957 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
5958 tree type, cond, tmp, count, exit_label, n, max, largest;
5960 stmtblock_t block, body;
5963 /* We store in charsize the size of a character. */
5964 i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
5965 size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
5967 /* Get the arguments. */
5968 gfc_conv_intrinsic_function_args (se, expr, args, 3);
5969 slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
5971 ncopies = gfc_evaluate_now (args[2], &se->pre);
5972 ncopies_type = TREE_TYPE (ncopies);
5974 /* Check that NCOPIES is not negative. */
5975 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, ncopies,
5976 build_int_cst (ncopies_type, 0));
5977 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
5978 "Argument NCOPIES of REPEAT intrinsic is negative "
5979 "(its value is %lld)",
5980 fold_convert (long_integer_type_node, ncopies));
5982 /* If the source length is zero, any non negative value of NCOPIES
5983 is valid, and nothing happens. */
5984 n = gfc_create_var (ncopies_type, "ncopies");
5985 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
5986 build_int_cst (size_type_node, 0));
5987 tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
5988 build_int_cst (ncopies_type, 0), ncopies);
5989 gfc_add_modify (&se->pre, n, tmp);
5992 /* Check that ncopies is not too large: ncopies should be less than
5993 (or equal to) MAX / slen, where MAX is the maximal integer of
5994 the gfc_charlen_type_node type. If slen == 0, we need a special
5995 case to avoid the division by zero. */
5996 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5997 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
5998 max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
5999 fold_convert (size_type_node, max), slen);
6000 largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
6001 ? size_type_node : ncopies_type;
6002 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
6003 fold_convert (largest, ncopies),
6004 fold_convert (largest, max));
6005 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
6006 build_int_cst (size_type_node, 0));
6007 cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp,
6008 boolean_false_node, cond);
6009 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
6010 "Argument NCOPIES of REPEAT intrinsic is too large");
6012 /* Compute the destination length. */
6013 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
6014 fold_convert (gfc_charlen_type_node, slen),
6015 fold_convert (gfc_charlen_type_node, ncopies));
6016 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
6017 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
6019 /* Generate the code to do the repeat operation:
6020 for (i = 0; i < ncopies; i++)
6021 memmove (dest + (i * slen * size), src, slen*size); */
6022 gfc_start_block (&block);
6023 count = gfc_create_var (ncopies_type, "count");
6024 gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
6025 exit_label = gfc_build_label_decl (NULL_TREE);
6027 /* Start the loop body. */
6028 gfc_start_block (&body);
6030 /* Exit the loop if count >= ncopies. */
6031 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, count,
6033 tmp = build1_v (GOTO_EXPR, exit_label);
6034 TREE_USED (exit_label) = 1;
6035 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6036 build_empty_stmt (input_location));
6037 gfc_add_expr_to_block (&body, tmp);
6039 /* Call memmove (dest + (i*slen*size), src, slen*size). */
6040 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
6041 fold_convert (gfc_charlen_type_node, slen),
6042 fold_convert (gfc_charlen_type_node, count));
6043 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
6044 tmp, fold_convert (gfc_charlen_type_node, size));
6045 tmp = fold_build_pointer_plus_loc (input_location,
6046 fold_convert (pvoid_type_node, dest), tmp);
6047 tmp = build_call_expr_loc (input_location,
6048 builtin_decl_explicit (BUILT_IN_MEMMOVE),
6050 fold_build2_loc (input_location, MULT_EXPR,
6051 size_type_node, slen,
6052 fold_convert (size_type_node,
6054 gfc_add_expr_to_block (&body, tmp);
6056 /* Increment count. */
6057 tmp = fold_build2_loc (input_location, PLUS_EXPR, ncopies_type,
6058 count, build_int_cst (TREE_TYPE (count), 1));
6059 gfc_add_modify (&body, count, tmp);
6061 /* Build the loop. */
6062 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
6063 gfc_add_expr_to_block (&block, tmp);
6065 /* Add the exit label. */
6066 tmp = build1_v (LABEL_EXPR, exit_label);
6067 gfc_add_expr_to_block (&block, tmp);
6069 /* Finish the block. */
6070 tmp = gfc_finish_block (&block);
6071 gfc_add_expr_to_block (&se->pre, tmp);
6073 /* Set the result value. */
6075 se->string_length = dlen;
6079 /* Generate code for the IARGC intrinsic. */
6082 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
6088 /* Call the library function. This always returns an INTEGER(4). */
6089 fndecl = gfor_fndecl_iargc;
6090 tmp = build_call_expr_loc (input_location,
6093 /* Convert it to the required type. */
6094 type = gfc_typenode_for_spec (&expr->ts);
6095 tmp = fold_convert (type, tmp);
6101 /* The loc intrinsic returns the address of its argument as
6102 gfc_index_integer_kind integer. */
6105 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
6111 gcc_assert (!se->ss);
6113 arg_expr = expr->value.function.actual->expr;
6114 ss = gfc_walk_expr (arg_expr);
6115 if (ss == gfc_ss_terminator)
6116 gfc_conv_expr_reference (se, arg_expr);
6118 gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL);
6119 se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
6121 /* Create a temporary variable for loc return value. Without this,
6122 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
6123 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
6124 gfc_add_modify (&se->pre, temp_var, se->expr);
6125 se->expr = temp_var;
6128 /* Generate code for an intrinsic function. Some map directly to library
6129 calls, others get special handling. In some cases the name of the function
6130 used depends on the type specifiers. */
6133 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
6139 name = &expr->value.function.name[2];
6143 lib = gfc_is_intrinsic_libcall (expr);
6147 se->ignore_optional = 1;
6149 switch (expr->value.function.isym->id)
6151 case GFC_ISYM_EOSHIFT:
6153 case GFC_ISYM_RESHAPE:
6154 /* For all of those the first argument specifies the type and the
6155 third is optional. */
6156 conv_generic_with_optional_char_arg (se, expr, 1, 3);
6160 gfc_conv_intrinsic_funcall (se, expr);
6168 switch (expr->value.function.isym->id)
6173 case GFC_ISYM_REPEAT:
6174 gfc_conv_intrinsic_repeat (se, expr);
6178 gfc_conv_intrinsic_trim (se, expr);
6181 case GFC_ISYM_SC_KIND:
6182 gfc_conv_intrinsic_sc_kind (se, expr);
6185 case GFC_ISYM_SI_KIND:
6186 gfc_conv_intrinsic_si_kind (se, expr);
6189 case GFC_ISYM_SR_KIND:
6190 gfc_conv_intrinsic_sr_kind (se, expr);
6193 case GFC_ISYM_EXPONENT:
6194 gfc_conv_intrinsic_exponent (se, expr);
6198 kind = expr->value.function.actual->expr->ts.kind;
6200 fndecl = gfor_fndecl_string_scan;
6202 fndecl = gfor_fndecl_string_scan_char4;
6206 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
6209 case GFC_ISYM_VERIFY:
6210 kind = expr->value.function.actual->expr->ts.kind;
6212 fndecl = gfor_fndecl_string_verify;
6214 fndecl = gfor_fndecl_string_verify_char4;
6218 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
6221 case GFC_ISYM_ALLOCATED:
6222 gfc_conv_allocated (se, expr);
6225 case GFC_ISYM_ASSOCIATED:
6226 gfc_conv_associated(se, expr);
6229 case GFC_ISYM_SAME_TYPE_AS:
6230 gfc_conv_same_type_as (se, expr);
6234 gfc_conv_intrinsic_abs (se, expr);
6237 case GFC_ISYM_ADJUSTL:
6238 if (expr->ts.kind == 1)
6239 fndecl = gfor_fndecl_adjustl;
6240 else if (expr->ts.kind == 4)
6241 fndecl = gfor_fndecl_adjustl_char4;
6245 gfc_conv_intrinsic_adjust (se, expr, fndecl);
6248 case GFC_ISYM_ADJUSTR:
6249 if (expr->ts.kind == 1)
6250 fndecl = gfor_fndecl_adjustr;
6251 else if (expr->ts.kind == 4)
6252 fndecl = gfor_fndecl_adjustr_char4;
6256 gfc_conv_intrinsic_adjust (se, expr, fndecl);
6259 case GFC_ISYM_AIMAG:
6260 gfc_conv_intrinsic_imagpart (se, expr);
6264 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
6268 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
6271 case GFC_ISYM_ANINT:
6272 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
6276 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
6280 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
6283 case GFC_ISYM_BTEST:
6284 gfc_conv_intrinsic_btest (se, expr);
6288 gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
6292 gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
6296 gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
6300 gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
6303 case GFC_ISYM_ACHAR:
6305 gfc_conv_intrinsic_char (se, expr);
6308 case GFC_ISYM_CONVERSION:
6310 case GFC_ISYM_LOGICAL:
6312 gfc_conv_intrinsic_conversion (se, expr);
6315 /* Integer conversions are handled separately to make sure we get the
6316 correct rounding mode. */
6321 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
6325 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
6328 case GFC_ISYM_CEILING:
6329 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
6332 case GFC_ISYM_FLOOR:
6333 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
6337 gfc_conv_intrinsic_mod (se, expr, 0);
6340 case GFC_ISYM_MODULO:
6341 gfc_conv_intrinsic_mod (se, expr, 1);
6344 case GFC_ISYM_CMPLX:
6345 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
6348 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
6349 gfc_conv_intrinsic_iargc (se, expr);
6352 case GFC_ISYM_COMPLEX:
6353 gfc_conv_intrinsic_cmplx (se, expr, 1);
6356 case GFC_ISYM_CONJG:
6357 gfc_conv_intrinsic_conjg (se, expr);
6360 case GFC_ISYM_COUNT:
6361 gfc_conv_intrinsic_count (se, expr);
6364 case GFC_ISYM_CTIME:
6365 gfc_conv_intrinsic_ctime (se, expr);
6369 gfc_conv_intrinsic_dim (se, expr);
6372 case GFC_ISYM_DOT_PRODUCT:
6373 gfc_conv_intrinsic_dot_product (se, expr);
6376 case GFC_ISYM_DPROD:
6377 gfc_conv_intrinsic_dprod (se, expr);
6380 case GFC_ISYM_DSHIFTL:
6381 gfc_conv_intrinsic_dshift (se, expr, true);
6384 case GFC_ISYM_DSHIFTR:
6385 gfc_conv_intrinsic_dshift (se, expr, false);
6388 case GFC_ISYM_FDATE:
6389 gfc_conv_intrinsic_fdate (se, expr);
6392 case GFC_ISYM_FRACTION:
6393 gfc_conv_intrinsic_fraction (se, expr);
6397 gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
6401 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
6405 gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
6408 case GFC_ISYM_IBCLR:
6409 gfc_conv_intrinsic_singlebitop (se, expr, 0);
6412 case GFC_ISYM_IBITS:
6413 gfc_conv_intrinsic_ibits (se, expr);
6416 case GFC_ISYM_IBSET:
6417 gfc_conv_intrinsic_singlebitop (se, expr, 1);
6420 case GFC_ISYM_IACHAR:
6421 case GFC_ISYM_ICHAR:
6422 /* We assume ASCII character sequence. */
6423 gfc_conv_intrinsic_ichar (se, expr);
6426 case GFC_ISYM_IARGC:
6427 gfc_conv_intrinsic_iargc (se, expr);
6431 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
6434 case GFC_ISYM_INDEX:
6435 kind = expr->value.function.actual->expr->ts.kind;
6437 fndecl = gfor_fndecl_string_index;
6439 fndecl = gfor_fndecl_string_index_char4;
6443 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
6447 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
6450 case GFC_ISYM_IPARITY:
6451 gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
6454 case GFC_ISYM_IS_IOSTAT_END:
6455 gfc_conv_has_intvalue (se, expr, LIBERROR_END);
6458 case GFC_ISYM_IS_IOSTAT_EOR:
6459 gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
6462 case GFC_ISYM_ISNAN:
6463 gfc_conv_intrinsic_isnan (se, expr);
6466 case GFC_ISYM_LSHIFT:
6467 gfc_conv_intrinsic_shift (se, expr, false, false);
6470 case GFC_ISYM_RSHIFT:
6471 gfc_conv_intrinsic_shift (se, expr, true, true);
6474 case GFC_ISYM_SHIFTA:
6475 gfc_conv_intrinsic_shift (se, expr, true, true);
6478 case GFC_ISYM_SHIFTL:
6479 gfc_conv_intrinsic_shift (se, expr, false, false);
6482 case GFC_ISYM_SHIFTR:
6483 gfc_conv_intrinsic_shift (se, expr, true, false);
6486 case GFC_ISYM_ISHFT:
6487 gfc_conv_intrinsic_ishft (se, expr);
6490 case GFC_ISYM_ISHFTC:
6491 gfc_conv_intrinsic_ishftc (se, expr);
6494 case GFC_ISYM_LEADZ:
6495 gfc_conv_intrinsic_leadz (se, expr);
6498 case GFC_ISYM_TRAILZ:
6499 gfc_conv_intrinsic_trailz (se, expr);
6502 case GFC_ISYM_POPCNT:
6503 gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
6506 case GFC_ISYM_POPPAR:
6507 gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
6510 case GFC_ISYM_LBOUND:
6511 gfc_conv_intrinsic_bound (se, expr, 0);
6514 case GFC_ISYM_LCOBOUND:
6515 conv_intrinsic_cobound (se, expr);
6518 case GFC_ISYM_TRANSPOSE:
6519 /* The scalarizer has already been set up for reversed dimension access
6520 order ; now we just get the argument value normally. */
6521 gfc_conv_expr (se, expr->value.function.actual->expr);
6525 gfc_conv_intrinsic_len (se, expr);
6528 case GFC_ISYM_LEN_TRIM:
6529 gfc_conv_intrinsic_len_trim (se, expr);
6533 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
6537 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
6541 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
6545 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
6548 case GFC_ISYM_MASKL:
6549 gfc_conv_intrinsic_mask (se, expr, 1);
6552 case GFC_ISYM_MASKR:
6553 gfc_conv_intrinsic_mask (se, expr, 0);
6557 if (expr->ts.type == BT_CHARACTER)
6558 gfc_conv_intrinsic_minmax_char (se, expr, 1);
6560 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
6563 case GFC_ISYM_MAXLOC:
6564 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
6567 case GFC_ISYM_MAXVAL:
6568 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
6571 case GFC_ISYM_MERGE:
6572 gfc_conv_intrinsic_merge (se, expr);
6575 case GFC_ISYM_MERGE_BITS:
6576 gfc_conv_intrinsic_merge_bits (se, expr);
6580 if (expr->ts.type == BT_CHARACTER)
6581 gfc_conv_intrinsic_minmax_char (se, expr, -1);
6583 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
6586 case GFC_ISYM_MINLOC:
6587 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
6590 case GFC_ISYM_MINVAL:
6591 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
6594 case GFC_ISYM_NEAREST:
6595 gfc_conv_intrinsic_nearest (se, expr);
6598 case GFC_ISYM_NORM2:
6599 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
6603 gfc_conv_intrinsic_not (se, expr);
6607 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
6610 case GFC_ISYM_PARITY:
6611 gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
6614 case GFC_ISYM_PRESENT:
6615 gfc_conv_intrinsic_present (se, expr);
6618 case GFC_ISYM_PRODUCT:
6619 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
6622 case GFC_ISYM_RRSPACING:
6623 gfc_conv_intrinsic_rrspacing (se, expr);
6626 case GFC_ISYM_SET_EXPONENT:
6627 gfc_conv_intrinsic_set_exponent (se, expr);
6630 case GFC_ISYM_SCALE:
6631 gfc_conv_intrinsic_scale (se, expr);
6635 gfc_conv_intrinsic_sign (se, expr);
6639 gfc_conv_intrinsic_size (se, expr);
6642 case GFC_ISYM_SIZEOF:
6643 case GFC_ISYM_C_SIZEOF:
6644 gfc_conv_intrinsic_sizeof (se, expr);
6647 case GFC_ISYM_STORAGE_SIZE:
6648 gfc_conv_intrinsic_storage_size (se, expr);
6651 case GFC_ISYM_SPACING:
6652 gfc_conv_intrinsic_spacing (se, expr);
6656 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
6659 case GFC_ISYM_TRANSFER:
6660 if (se->ss && se->ss->info->useflags)
6661 /* Access the previously obtained result. */
6662 gfc_conv_tmp_array_ref (se);
6664 gfc_conv_intrinsic_transfer (se, expr);
6667 case GFC_ISYM_TTYNAM:
6668 gfc_conv_intrinsic_ttynam (se, expr);
6671 case GFC_ISYM_UBOUND:
6672 gfc_conv_intrinsic_bound (se, expr, 1);
6675 case GFC_ISYM_UCOBOUND:
6676 conv_intrinsic_cobound (se, expr);
6680 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
6684 gfc_conv_intrinsic_loc (se, expr);
6687 case GFC_ISYM_THIS_IMAGE:
6688 /* For num_images() == 1, handle as LCOBOUND. */
6689 if (expr->value.function.actual->expr
6690 && gfc_option.coarray == GFC_FCOARRAY_SINGLE)
6691 conv_intrinsic_cobound (se, expr);
6693 trans_this_image (se, expr);
6696 case GFC_ISYM_IMAGE_INDEX:
6697 trans_image_index (se, expr);
6700 case GFC_ISYM_NUM_IMAGES:
6701 trans_num_images (se);
6704 case GFC_ISYM_ACCESS:
6705 case GFC_ISYM_CHDIR:
6706 case GFC_ISYM_CHMOD:
6707 case GFC_ISYM_DTIME:
6708 case GFC_ISYM_ETIME:
6709 case GFC_ISYM_EXTENDS_TYPE_OF:
6711 case GFC_ISYM_FGETC:
6714 case GFC_ISYM_FPUTC:
6715 case GFC_ISYM_FSTAT:
6716 case GFC_ISYM_FTELL:
6717 case GFC_ISYM_GETCWD:
6718 case GFC_ISYM_GETGID:
6719 case GFC_ISYM_GETPID:
6720 case GFC_ISYM_GETUID:
6721 case GFC_ISYM_HOSTNM:
6723 case GFC_ISYM_IERRNO:
6724 case GFC_ISYM_IRAND:
6725 case GFC_ISYM_ISATTY:
6728 case GFC_ISYM_LSTAT:
6729 case GFC_ISYM_MALLOC:
6730 case GFC_ISYM_MATMUL:
6731 case GFC_ISYM_MCLOCK:
6732 case GFC_ISYM_MCLOCK8:
6734 case GFC_ISYM_RENAME:
6735 case GFC_ISYM_SECOND:
6736 case GFC_ISYM_SECNDS:
6737 case GFC_ISYM_SIGNAL:
6739 case GFC_ISYM_SYMLNK:
6740 case GFC_ISYM_SYSTEM:
6742 case GFC_ISYM_TIME8:
6743 case GFC_ISYM_UMASK:
6744 case GFC_ISYM_UNLINK:
6746 gfc_conv_intrinsic_funcall (se, expr);
6749 case GFC_ISYM_EOSHIFT:
6751 case GFC_ISYM_RESHAPE:
6752 /* For those, expr->rank should always be >0 and thus the if above the
6753 switch should have matched. */
6758 gfc_conv_intrinsic_lib_function (se, expr);
6765 walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
6767 gfc_ss *arg_ss, *tmp_ss;
6768 gfc_actual_arglist *arg;
6770 arg = expr->value.function.actual;
6772 gcc_assert (arg->expr);
6774 arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
6775 gcc_assert (arg_ss != gfc_ss_terminator);
6777 for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
6779 if (tmp_ss->info->type != GFC_SS_SCALAR
6780 && tmp_ss->info->type != GFC_SS_REFERENCE)
6784 gcc_assert (tmp_ss->dimen == 2);
6786 /* We just invert dimensions. */
6787 tmp_dim = tmp_ss->dim[0];
6788 tmp_ss->dim[0] = tmp_ss->dim[1];
6789 tmp_ss->dim[1] = tmp_dim;
6792 /* Stop when tmp_ss points to the last valid element of the chain... */
6793 if (tmp_ss->next == gfc_ss_terminator)
6797 /* ... so that we can attach the rest of the chain to it. */
6805 walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
6808 switch (expr->value.function.isym->id)
6810 case GFC_ISYM_TRANSPOSE:
6811 return walk_inline_intrinsic_transpose (ss, expr);
6820 /* This generates code to execute before entering the scalarization loop.
6821 Currently does nothing. */
6824 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
6826 switch (ss->info->expr->value.function.isym->id)
6828 case GFC_ISYM_UBOUND:
6829 case GFC_ISYM_LBOUND:
6830 case GFC_ISYM_UCOBOUND:
6831 case GFC_ISYM_LCOBOUND:
6832 case GFC_ISYM_THIS_IMAGE:
6841 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
6842 are expanded into code inside the scalarization loop. */
6845 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
6847 /* The two argument version returns a scalar. */
6848 if (expr->value.function.actual->next->expr)
6851 return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
6855 /* Walk an intrinsic array libcall. */
6858 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
6860 gcc_assert (expr->rank > 0);
6861 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
6865 /* Return whether the function call expression EXPR will be expanded
6866 inline by gfc_conv_intrinsic_function. */
6869 gfc_inline_intrinsic_function_p (gfc_expr *expr)
6871 if (!expr->value.function.isym)
6874 switch (expr->value.function.isym->id)
6876 case GFC_ISYM_TRANSPOSE:
6885 /* Returns nonzero if the specified intrinsic function call maps directly to
6886 an external library call. Should only be used for functions that return
6890 gfc_is_intrinsic_libcall (gfc_expr * expr)
6892 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
6893 gcc_assert (expr->rank > 0);
6895 if (gfc_inline_intrinsic_function_p (expr))
6898 switch (expr->value.function.isym->id)
6902 case GFC_ISYM_COUNT:
6906 case GFC_ISYM_IPARITY:
6907 case GFC_ISYM_MATMUL:
6908 case GFC_ISYM_MAXLOC:
6909 case GFC_ISYM_MAXVAL:
6910 case GFC_ISYM_MINLOC:
6911 case GFC_ISYM_MINVAL:
6912 case GFC_ISYM_NORM2:
6913 case GFC_ISYM_PARITY:
6914 case GFC_ISYM_PRODUCT:
6916 case GFC_ISYM_SHAPE:
6917 case GFC_ISYM_SPREAD:
6919 /* Ignore absent optional parameters. */
6922 case GFC_ISYM_RESHAPE:
6923 case GFC_ISYM_CSHIFT:
6924 case GFC_ISYM_EOSHIFT:
6926 case GFC_ISYM_UNPACK:
6927 /* Pass absent optional parameters. */
6935 /* Walk an intrinsic function. */
6937 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
6938 gfc_intrinsic_sym * isym)
6942 if (isym->elemental)
6943 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6946 if (expr->rank == 0)
6949 if (gfc_inline_intrinsic_function_p (expr))
6950 return walk_inline_intrinsic_function (ss, expr);
6952 if (gfc_is_intrinsic_libcall (expr))
6953 return gfc_walk_intrinsic_libfunc (ss, expr);
6955 /* Special cases. */
6958 case GFC_ISYM_LBOUND:
6959 case GFC_ISYM_LCOBOUND:
6960 case GFC_ISYM_UBOUND:
6961 case GFC_ISYM_UCOBOUND:
6962 case GFC_ISYM_THIS_IMAGE:
6963 return gfc_walk_intrinsic_bound (ss, expr);
6965 case GFC_ISYM_TRANSFER:
6966 return gfc_walk_intrinsic_libfunc (ss, expr);
6969 /* This probably meant someone forgot to add an intrinsic to the above
6970 list(s) when they implemented it, or something's gone horribly
6978 conv_intrinsic_atomic_def (gfc_code *code)
6983 gfc_init_se (&atom, NULL);
6984 gfc_init_se (&value, NULL);
6985 gfc_conv_expr (&atom, code->ext.actual->expr);
6986 gfc_conv_expr (&value, code->ext.actual->next->expr);
6988 gfc_init_block (&block);
6989 gfc_add_modify (&block, atom.expr,
6990 fold_convert (TREE_TYPE (atom.expr), value.expr));
6991 return gfc_finish_block (&block);
6996 conv_intrinsic_atomic_ref (gfc_code *code)
7001 gfc_init_se (&atom, NULL);
7002 gfc_init_se (&value, NULL);
7003 gfc_conv_expr (&value, code->ext.actual->expr);
7004 gfc_conv_expr (&atom, code->ext.actual->next->expr);
7006 gfc_init_block (&block);
7007 gfc_add_modify (&block, value.expr,
7008 fold_convert (TREE_TYPE (value.expr), atom.expr));
7009 return gfc_finish_block (&block);
7014 conv_intrinsic_move_alloc (gfc_code *code)
7016 if (code->ext.actual->expr->rank == 0)
7018 /* Scalar arguments: Generate pointer assignments. */
7019 gfc_expr *from, *to, *deal;
7024 from = code->ext.actual->expr;
7025 to = code->ext.actual->next->expr;
7027 gfc_start_block (&block);
7029 /* Deallocate 'TO' argument. */
7030 gfc_init_se (&se, NULL);
7031 se.want_pointer = 1;
7032 deal = gfc_copy_expr (to);
7033 if (deal->ts.type == BT_CLASS)
7034 gfc_add_data_component (deal);
7035 gfc_conv_expr (&se, deal);
7036 tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
7038 gfc_add_expr_to_block (&block, tmp);
7039 gfc_free_expr (deal);
7041 if (to->ts.type == BT_CLASS)
7042 tmp = gfc_trans_class_assign (to, from, EXEC_POINTER_ASSIGN);
7044 tmp = gfc_trans_pointer_assignment (to, from);
7045 gfc_add_expr_to_block (&block, tmp);
7047 if (from->ts.type == BT_CLASS)
7048 tmp = gfc_trans_class_assign (from, gfc_get_null_expr (NULL),
7049 EXEC_POINTER_ASSIGN);
7051 tmp = gfc_trans_pointer_assignment (from,
7052 gfc_get_null_expr (NULL));
7053 gfc_add_expr_to_block (&block, tmp);
7055 return gfc_finish_block (&block);
7058 /* Array arguments: Generate library code. */
7059 return gfc_trans_call (code, false, NULL_TREE, NULL_TREE, false);
7064 gfc_conv_intrinsic_subroutine (gfc_code *code)
7068 gcc_assert (code->resolved_isym);
7070 switch (code->resolved_isym->id)
7072 case GFC_ISYM_MOVE_ALLOC:
7073 res = conv_intrinsic_move_alloc (code);
7076 case GFC_ISYM_ATOMIC_DEF:
7077 res = conv_intrinsic_atomic_def (code);
7080 case GFC_ISYM_ATOMIC_REF:
7081 res = conv_intrinsic_atomic_ref (code);
7092 #include "gt-fortran-trans-intrinsic.h"