1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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 int 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 : built_in_decls[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 (REALPART_EXPR, artype, args[0]);
337 se->expr = convert (type, args[0]);
340 /* This is needed because the gcc backend only implements
341 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
342 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
343 Similarly for CEILING. */
346 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
353 argtype = TREE_TYPE (arg);
354 arg = gfc_evaluate_now (arg, pblock);
356 intval = convert (type, arg);
357 intval = gfc_evaluate_now (intval, pblock);
359 tmp = convert (argtype, intval);
360 cond = fold_build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
362 tmp = fold_build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
363 build_int_cst (type, 1));
364 tmp = fold_build3 (COND_EXPR, type, cond, intval, tmp);
369 /* Round to nearest integer, away from zero. */
372 build_round_expr (tree arg, tree restype)
377 int argprec, resprec;
379 argtype = TREE_TYPE (arg);
380 argprec = TYPE_PRECISION (argtype);
381 resprec = TYPE_PRECISION (restype);
383 /* Depending on the type of the result, choose the long int intrinsic
384 (lround family) or long long intrinsic (llround). We might also
385 need to convert the result afterwards. */
386 if (resprec <= LONG_TYPE_SIZE)
388 else if (resprec <= LONG_LONG_TYPE_SIZE)
393 /* Now, depending on the argument type, we choose between intrinsics. */
395 fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
397 fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
399 return fold_convert (restype, build_call_expr_loc (input_location,
404 /* Convert a real to an integer using a specific rounding mode.
405 Ideally we would just build the corresponding GENERIC node,
406 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
409 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
410 enum rounding_mode op)
415 return build_fixbound_expr (pblock, arg, type, 0);
419 return build_fixbound_expr (pblock, arg, type, 1);
423 return build_round_expr (arg, type);
427 return fold_build1 (FIX_TRUNC_EXPR, type, arg);
436 /* Round a real value using the specified rounding mode.
437 We use a temporary integer of that same kind size as the result.
438 Values larger than those that can be represented by this kind are
439 unchanged, as they will not be accurate enough to represent the
441 huge = HUGE (KIND (a))
442 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
446 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
458 kind = expr->ts.kind;
459 nargs = gfc_intrinsic_argument_list_length (expr);
462 /* We have builtin functions for some cases. */
466 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
470 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
477 /* Evaluate the argument. */
478 gcc_assert (expr->value.function.actual->expr);
479 gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
481 /* Use a builtin function if one exists. */
482 if (decl != NULL_TREE)
484 se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
488 /* This code is probably redundant, but we'll keep it lying around just
490 type = gfc_typenode_for_spec (&expr->ts);
491 arg[0] = gfc_evaluate_now (arg[0], &se->pre);
493 /* Test if the value is too large to handle sensibly. */
494 gfc_set_model_kind (kind);
496 n = gfc_validate_kind (BT_INTEGER, kind, false);
497 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
498 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
499 cond = fold_build2 (LT_EXPR, boolean_type_node, arg[0], tmp);
501 mpfr_neg (huge, huge, GFC_RND_MODE);
502 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
503 tmp = fold_build2 (GT_EXPR, boolean_type_node, arg[0], tmp);
504 cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
505 itype = gfc_get_int_type (kind);
507 tmp = build_fix_expr (&se->pre, arg[0], itype, op);
508 tmp = convert (type, tmp);
509 se->expr = fold_build3 (COND_EXPR, type, cond, tmp, arg[0]);
514 /* Convert to an integer using the specified rounding mode. */
517 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
523 nargs = gfc_intrinsic_argument_list_length (expr);
524 args = XALLOCAVEC (tree, nargs);
526 /* Evaluate the argument, we process all arguments even though we only
527 use the first one for code generation purposes. */
528 type = gfc_typenode_for_spec (&expr->ts);
529 gcc_assert (expr->value.function.actual->expr);
530 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
532 if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
534 /* Conversion to a different integer kind. */
535 se->expr = convert (type, args[0]);
539 /* Conversion from complex to non-complex involves taking the real
540 component of the value. */
541 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
542 && expr->ts.type != BT_COMPLEX)
546 artype = TREE_TYPE (TREE_TYPE (args[0]));
547 args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
550 se->expr = build_fix_expr (&se->pre, args[0], type, op);
555 /* Get the imaginary component of a value. */
558 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
562 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
563 se->expr = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
567 /* Get the complex conjugate of a value. */
570 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
574 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
575 se->expr = fold_build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
581 define_quad_builtin (const char *name, tree type, bool is_const)
584 fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
587 /* Mark the decl as external. */
588 DECL_EXTERNAL (fndecl) = 1;
589 TREE_PUBLIC (fndecl) = 1;
591 /* Mark it __attribute__((const)). */
592 TREE_READONLY (fndecl) = is_const;
594 rest_of_decl_compilation (fndecl, 1, 0);
601 /* Initialize function decls for library functions. The external functions
602 are created as required. Builtin functions are added here. */
605 gfc_build_intrinsic_lib_fndecls (void)
607 gfc_intrinsic_map_t *m;
608 tree quad_decls[END_BUILTINS + 1];
610 if (gfc_real16_is_float128)
612 /* If we have soft-float types, we create the decls for their
613 C99-like library functions. For now, we only handle __float128
614 q-suffixed functions. */
616 tree tmp, func_0, func_1, func_2, func_cabs, func_frexp;
617 tree func_lround, func_llround, func_scalbn, func_cpow;
619 memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
621 /* type (*) (void) */
622 func_0 = build_function_type (float128_type_node, void_list_node);
623 /* type (*) (type) */
624 tmp = tree_cons (NULL_TREE, float128_type_node, void_list_node);
625 func_1 = build_function_type (float128_type_node, tmp);
626 /* long (*) (type) */
627 func_lround = build_function_type (long_integer_type_node, tmp);
628 /* long long (*) (type) */
629 func_llround = build_function_type (long_long_integer_type_node, tmp);
630 /* type (*) (type, type) */
631 tmp = tree_cons (NULL_TREE, float128_type_node, tmp);
632 func_2 = build_function_type (float128_type_node, tmp);
633 /* type (*) (type, &int) */
634 tmp = tree_cons (NULL_TREE, float128_type_node, void_list_node);
635 tmp = tree_cons (NULL_TREE, build_pointer_type (integer_type_node), tmp);
636 func_frexp = build_function_type (float128_type_node, tmp);
637 /* type (*) (type, int) */
638 tmp = tree_cons (NULL_TREE, float128_type_node, void_list_node);
639 tmp = tree_cons (NULL_TREE, integer_type_node, tmp);
640 func_scalbn = build_function_type (float128_type_node, tmp);
641 /* type (*) (complex type) */
642 tmp = tree_cons (NULL_TREE, complex_float128_type_node, void_list_node);
643 func_cabs = build_function_type (float128_type_node, tmp);
644 /* complex type (*) (complex type, complex type) */
645 tmp = tree_cons (NULL_TREE, complex_float128_type_node, tmp);
646 func_cpow = build_function_type (complex_float128_type_node, tmp);
648 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
649 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
650 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
652 /* Only these built-ins are actually needed here. These are used directly
653 from the code, when calling builtin_decl_for_precision() or
654 builtin_decl_for_float_type(). The others are all constructed by
655 gfc_get_intrinsic_lib_fndecl(). */
656 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
657 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
659 #include "mathbuiltins.def"
663 #undef DEFINE_MATH_BUILTIN
664 #undef DEFINE_MATH_BUILTIN_C
668 /* Add GCC builtin functions. */
669 for (m = gfc_intrinsic_map;
670 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
672 if (m->float_built_in != END_BUILTINS)
673 m->real4_decl = built_in_decls[m->float_built_in];
674 if (m->complex_float_built_in != END_BUILTINS)
675 m->complex4_decl = built_in_decls[m->complex_float_built_in];
676 if (m->double_built_in != END_BUILTINS)
677 m->real8_decl = built_in_decls[m->double_built_in];
678 if (m->complex_double_built_in != END_BUILTINS)
679 m->complex8_decl = built_in_decls[m->complex_double_built_in];
681 /* If real(kind=10) exists, it is always long double. */
682 if (m->long_double_built_in != END_BUILTINS)
683 m->real10_decl = built_in_decls[m->long_double_built_in];
684 if (m->complex_long_double_built_in != END_BUILTINS)
685 m->complex10_decl = built_in_decls[m->complex_long_double_built_in];
687 if (!gfc_real16_is_float128)
689 if (m->long_double_built_in != END_BUILTINS)
690 m->real16_decl = built_in_decls[m->long_double_built_in];
691 if (m->complex_long_double_built_in != END_BUILTINS)
692 m->complex16_decl = built_in_decls[m->complex_long_double_built_in];
694 else if (quad_decls[m->double_built_in] != NULL_TREE)
696 /* Quad-precision function calls are constructed when first
697 needed by builtin_decl_for_precision(), except for those
698 that will be used directly (define by OTHER_BUILTIN). */
699 m->real16_decl = quad_decls[m->double_built_in];
701 else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
703 /* Same thing for the complex ones. */
704 m->complex16_decl = quad_decls[m->double_built_in];
710 /* Create a fndecl for a simple intrinsic library function. */
713 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
718 gfc_actual_arglist *actual;
721 char name[GFC_MAX_SYMBOL_LEN + 3];
724 if (ts->type == BT_REAL)
729 pdecl = &m->real4_decl;
732 pdecl = &m->real8_decl;
735 pdecl = &m->real10_decl;
738 pdecl = &m->real16_decl;
744 else if (ts->type == BT_COMPLEX)
746 gcc_assert (m->complex_available);
751 pdecl = &m->complex4_decl;
754 pdecl = &m->complex8_decl;
757 pdecl = &m->complex10_decl;
760 pdecl = &m->complex16_decl;
774 int n = gfc_validate_kind (BT_REAL, ts->kind, false);
775 if (gfc_real_kinds[n].c_float)
776 snprintf (name, sizeof (name), "%s%s%s",
777 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
778 else if (gfc_real_kinds[n].c_double)
779 snprintf (name, sizeof (name), "%s%s",
780 ts->type == BT_COMPLEX ? "c" : "", m->name);
781 else if (gfc_real_kinds[n].c_long_double)
782 snprintf (name, sizeof (name), "%s%s%s",
783 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
784 else if (gfc_real_kinds[n].c_float128)
785 snprintf (name, sizeof (name), "%s%s%s",
786 ts->type == BT_COMPLEX ? "c" : "", m->name, "q");
792 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
793 ts->type == BT_COMPLEX ? 'c' : 'r',
797 argtypes = NULL_TREE;
798 for (actual = expr->value.function.actual; actual; actual = actual->next)
800 type = gfc_typenode_for_spec (&actual->expr->ts);
801 argtypes = gfc_chainon_list (argtypes, type);
803 argtypes = chainon (argtypes, void_list_node);
804 type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
805 fndecl = build_decl (input_location,
806 FUNCTION_DECL, get_identifier (name), type);
808 /* Mark the decl as external. */
809 DECL_EXTERNAL (fndecl) = 1;
810 TREE_PUBLIC (fndecl) = 1;
812 /* Mark it __attribute__((const)), if possible. */
813 TREE_READONLY (fndecl) = m->is_constant;
815 rest_of_decl_compilation (fndecl, 1, 0);
822 /* Convert an intrinsic function into an external or builtin call. */
825 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
827 gfc_intrinsic_map_t *m;
831 unsigned int num_args;
834 id = expr->value.function.isym->id;
835 /* Find the entry for this function. */
836 for (m = gfc_intrinsic_map;
837 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
843 if (m->id == GFC_ISYM_NONE)
845 internal_error ("Intrinsic function %s(%d) not recognized",
846 expr->value.function.name, id);
849 /* Get the decl and generate the call. */
850 num_args = gfc_intrinsic_argument_list_length (expr);
851 args = XALLOCAVEC (tree, num_args);
853 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
854 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
855 rettype = TREE_TYPE (TREE_TYPE (fndecl));
857 fndecl = build_addr (fndecl, current_function_decl);
858 se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
862 /* If bounds-checking is enabled, create code to verify at runtime that the
863 string lengths for both expressions are the same (needed for e.g. MERGE).
864 If bounds-checking is not enabled, does nothing. */
867 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
868 tree a, tree b, stmtblock_t* target)
873 /* If bounds-checking is disabled, do nothing. */
874 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
877 /* Compare the two string lengths. */
878 cond = fold_build2 (NE_EXPR, boolean_type_node, a, b);
880 /* Output the runtime-check. */
881 name = gfc_build_cstring_const (intr_name);
882 name = gfc_build_addr_expr (pchar_type_node, name);
883 gfc_trans_runtime_check (true, false, cond, target, where,
884 "Unequal character lengths (%ld/%ld) in %s",
885 fold_convert (long_integer_type_node, a),
886 fold_convert (long_integer_type_node, b), name);
890 /* The EXPONENT(s) intrinsic function is translated into
897 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
899 tree arg, type, res, tmp, frexp;
901 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
902 expr->value.function.actual->expr->ts.kind);
904 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
906 res = gfc_create_var (integer_type_node, NULL);
907 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
908 gfc_build_addr_expr (NULL_TREE, res));
909 gfc_add_expr_to_block (&se->pre, tmp);
911 type = gfc_typenode_for_spec (&expr->ts);
912 se->expr = fold_convert (type, res);
915 /* Evaluate a single upper or lower bound. */
916 /* TODO: bound intrinsic generates way too much unnecessary code. */
919 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
921 gfc_actual_arglist *arg;
922 gfc_actual_arglist *arg2;
927 tree cond, cond1, cond3, cond4, size;
934 arg = expr->value.function.actual;
939 /* Create an implicit second parameter from the loop variable. */
940 gcc_assert (!arg2->expr);
941 gcc_assert (se->loop->dimen == 1);
942 gcc_assert (se->ss->expr == expr);
943 gfc_advance_se_ss_chain (se);
944 bound = se->loop->loopvar[0];
945 bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
950 /* use the passed argument. */
951 gcc_assert (arg->next->expr);
952 gfc_init_se (&argse, NULL);
953 gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
954 gfc_add_block_to_block (&se->pre, &argse.pre);
956 /* Convert from one based to zero based. */
957 bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
961 /* TODO: don't re-evaluate the descriptor on each iteration. */
962 /* Get a descriptor for the first parameter. */
963 ss = gfc_walk_expr (arg->expr);
964 gcc_assert (ss != gfc_ss_terminator);
965 gfc_init_se (&argse, NULL);
966 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
967 gfc_add_block_to_block (&se->pre, &argse.pre);
968 gfc_add_block_to_block (&se->post, &argse.post);
972 if (INTEGER_CST_P (bound))
976 hi = TREE_INT_CST_HIGH (bound);
977 low = TREE_INT_CST_LOW (bound);
978 if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
979 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
980 "dimension index", upper ? "UBOUND" : "LBOUND",
985 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
987 bound = gfc_evaluate_now (bound, &se->pre);
988 cond = fold_build2 (LT_EXPR, boolean_type_node,
989 bound, build_int_cst (TREE_TYPE (bound), 0));
990 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
991 tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
992 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
993 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
998 ubound = gfc_conv_descriptor_ubound_get (desc, bound);
999 lbound = gfc_conv_descriptor_lbound_get (desc, bound);
1001 as = gfc_get_full_arrayspec_from_expr (arg->expr);
1003 /* 13.14.53: Result value for LBOUND
1005 Case (i): For an array section or for an array expression other than a
1006 whole array or array structure component, LBOUND(ARRAY, DIM)
1007 has the value 1. For a whole array or array structure
1008 component, LBOUND(ARRAY, DIM) has the value:
1009 (a) equal to the lower bound for subscript DIM of ARRAY if
1010 dimension DIM of ARRAY does not have extent zero
1011 or if ARRAY is an assumed-size array of rank DIM,
1014 13.14.113: Result value for UBOUND
1016 Case (i): For an array section or for an array expression other than a
1017 whole array or array structure component, UBOUND(ARRAY, DIM)
1018 has the value equal to the number of elements in the given
1019 dimension; otherwise, it has a value equal to the upper bound
1020 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1021 not have size zero and has value zero if dimension DIM has
1026 tree stride = gfc_conv_descriptor_stride_get (desc, bound);
1028 cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
1030 cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
1031 gfc_index_zero_node);
1032 cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
1034 cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
1035 gfc_index_zero_node);
1040 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
1042 cond5 = fold_build2 (EQ_EXPR, boolean_type_node, gfc_index_one_node, lbound);
1043 cond5 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond5);
1045 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond5);
1047 se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
1048 ubound, gfc_index_zero_node);
1052 if (as->type == AS_ASSUMED_SIZE)
1053 cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
1054 build_int_cst (TREE_TYPE (bound),
1055 arg->expr->rank - 1));
1057 cond = boolean_false_node;
1059 cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
1060 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
1062 se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
1063 lbound, gfc_index_one_node);
1070 size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
1071 se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
1072 gfc_index_one_node);
1073 se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
1074 gfc_index_zero_node);
1077 se->expr = gfc_index_one_node;
1080 type = gfc_typenode_for_spec (&expr->ts);
1081 se->expr = convert (type, se->expr);
1086 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
1090 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1092 switch (expr->value.function.actual->expr->ts.type)
1096 se->expr = fold_build1 (ABS_EXPR, TREE_TYPE (arg), arg);
1100 cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
1101 se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
1110 /* Create a complex value from one or two real components. */
1113 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1119 unsigned int num_args;
1121 num_args = gfc_intrinsic_argument_list_length (expr);
1122 args = XALLOCAVEC (tree, num_args);
1124 type = gfc_typenode_for_spec (&expr->ts);
1125 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1126 real = convert (TREE_TYPE (type), args[0]);
1128 imag = convert (TREE_TYPE (type), args[1]);
1129 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1131 imag = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])),
1133 imag = convert (TREE_TYPE (type), imag);
1136 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1138 se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
1141 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1142 MODULO(A, P) = A - FLOOR (A / P) * P */
1143 /* TODO: MOD(x, 0) */
1146 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1158 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1160 switch (expr->ts.type)
1163 /* Integer case is easy, we've got a builtin op. */
1164 type = TREE_TYPE (args[0]);
1167 se->expr = fold_build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
1169 se->expr = fold_build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
1174 /* Check if we have a builtin fmod. */
1175 fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
1177 /* Use it if it exists. */
1178 if (fmod != NULL_TREE)
1180 tmp = build_addr (fmod, current_function_decl);
1181 se->expr = build_call_array_loc (input_location,
1182 TREE_TYPE (TREE_TYPE (fmod)),
1188 type = TREE_TYPE (args[0]);
1190 args[0] = gfc_evaluate_now (args[0], &se->pre);
1191 args[1] = gfc_evaluate_now (args[1], &se->pre);
1194 modulo = arg - floor (arg/arg2) * arg2, so
1195 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1197 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1198 thereby avoiding another division and retaining the accuracy
1199 of the builtin function. */
1200 if (fmod != NULL_TREE && modulo)
1202 tree zero = gfc_build_const (type, integer_zero_node);
1203 tmp = gfc_evaluate_now (se->expr, &se->pre);
1204 test = fold_build2 (LT_EXPR, boolean_type_node, args[0], zero);
1205 test2 = fold_build2 (LT_EXPR, boolean_type_node, args[1], zero);
1206 test2 = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
1207 test = fold_build2 (NE_EXPR, boolean_type_node, tmp, zero);
1208 test = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1209 test = gfc_evaluate_now (test, &se->pre);
1210 se->expr = fold_build3 (COND_EXPR, type, test,
1211 fold_build2 (PLUS_EXPR, type, tmp, args[1]),
1216 /* If we do not have a built_in fmod, the calculation is going to
1217 have to be done longhand. */
1218 tmp = fold_build2 (RDIV_EXPR, type, args[0], args[1]);
1220 /* Test if the value is too large to handle sensibly. */
1221 gfc_set_model_kind (expr->ts.kind);
1223 n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1224 ikind = expr->ts.kind;
1227 n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1228 ikind = gfc_max_integer_kind;
1230 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1231 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1232 test2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, test);
1234 mpfr_neg (huge, huge, GFC_RND_MODE);
1235 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1236 test = fold_build2 (GT_EXPR, boolean_type_node, tmp, test);
1237 test2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1239 itype = gfc_get_int_type (ikind);
1241 tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1243 tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1244 tmp = convert (type, tmp);
1245 tmp = fold_build3 (COND_EXPR, type, test2, tmp, args[0]);
1246 tmp = fold_build2 (MULT_EXPR, type, tmp, args[1]);
1247 se->expr = fold_build2 (MINUS_EXPR, type, args[0], tmp);
1256 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1259 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1267 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1268 type = TREE_TYPE (args[0]);
1270 val = fold_build2 (MINUS_EXPR, type, args[0], args[1]);
1271 val = gfc_evaluate_now (val, &se->pre);
1273 zero = gfc_build_const (type, integer_zero_node);
1274 tmp = fold_build2 (LE_EXPR, boolean_type_node, val, zero);
1275 se->expr = fold_build3 (COND_EXPR, type, tmp, zero, val);
1279 /* SIGN(A, B) is absolute value of A times sign of B.
1280 The real value versions use library functions to ensure the correct
1281 handling of negative zero. Integer case implemented as:
1282 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1286 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1292 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1293 if (expr->ts.type == BT_REAL)
1297 tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
1298 abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
1300 /* We explicitly have to ignore the minus sign. We do so by using
1301 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1302 if (!gfc_option.flag_sign_zero
1303 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
1306 zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
1307 cond = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
1308 se->expr = fold_build3 (COND_EXPR, TREE_TYPE (args[0]), cond,
1309 build_call_expr_loc (input_location, abs, 1,
1311 build_call_expr_loc (input_location, tmp, 2,
1315 se->expr = build_call_expr_loc (input_location, tmp, 2,
1320 /* Having excluded floating point types, we know we are now dealing
1321 with signed integer types. */
1322 type = TREE_TYPE (args[0]);
1324 /* Args[0] is used multiple times below. */
1325 args[0] = gfc_evaluate_now (args[0], &se->pre);
1327 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1328 the signs of A and B are the same, and of all ones if they differ. */
1329 tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
1330 tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
1331 build_int_cst (type, TYPE_PRECISION (type) - 1));
1332 tmp = gfc_evaluate_now (tmp, &se->pre);
1334 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1335 is all ones (i.e. -1). */
1336 se->expr = fold_build2 (BIT_XOR_EXPR, type,
1337 fold_build2 (PLUS_EXPR, type, args[0], tmp),
1342 /* Test for the presence of an optional argument. */
1345 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1349 arg = expr->value.function.actual->expr;
1350 gcc_assert (arg->expr_type == EXPR_VARIABLE);
1351 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1352 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1356 /* Calculate the double precision product of two single precision values. */
1359 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1364 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1366 /* Convert the args to double precision before multiplying. */
1367 type = gfc_typenode_for_spec (&expr->ts);
1368 args[0] = convert (type, args[0]);
1369 args[1] = convert (type, args[1]);
1370 se->expr = fold_build2 (MULT_EXPR, type, args[0], args[1]);
1374 /* Return a length one character string containing an ascii character. */
1377 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1382 unsigned int num_args;
1384 num_args = gfc_intrinsic_argument_list_length (expr);
1385 gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
1387 type = gfc_get_char_type (expr->ts.kind);
1388 var = gfc_create_var (type, "char");
1390 arg[0] = fold_build1 (NOP_EXPR, type, arg[0]);
1391 gfc_add_modify (&se->pre, var, arg[0]);
1392 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1393 se->string_length = integer_one_node;
1398 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1406 unsigned int num_args;
1408 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1409 args = XALLOCAVEC (tree, num_args);
1411 var = gfc_create_var (pchar_type_node, "pstr");
1412 len = gfc_create_var (gfc_get_int_type (8), "len");
1414 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1415 args[0] = gfc_build_addr_expr (NULL_TREE, var);
1416 args[1] = gfc_build_addr_expr (NULL_TREE, len);
1418 fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
1419 tmp = build_call_array_loc (input_location,
1420 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
1421 fndecl, num_args, args);
1422 gfc_add_expr_to_block (&se->pre, tmp);
1424 /* Free the temporary afterwards, if necessary. */
1425 cond = fold_build2 (GT_EXPR, boolean_type_node,
1426 len, build_int_cst (TREE_TYPE (len), 0));
1427 tmp = gfc_call_free (var);
1428 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1429 gfc_add_expr_to_block (&se->post, tmp);
1432 se->string_length = len;
1437 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1445 unsigned int num_args;
1447 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1448 args = XALLOCAVEC (tree, num_args);
1450 var = gfc_create_var (pchar_type_node, "pstr");
1451 len = gfc_create_var (gfc_charlen_type_node, "len");
1453 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1454 args[0] = gfc_build_addr_expr (NULL_TREE, var);
1455 args[1] = gfc_build_addr_expr (NULL_TREE, len);
1457 fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
1458 tmp = build_call_array_loc (input_location,
1459 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
1460 fndecl, num_args, args);
1461 gfc_add_expr_to_block (&se->pre, tmp);
1463 /* Free the temporary afterwards, if necessary. */
1464 cond = fold_build2 (GT_EXPR, boolean_type_node,
1465 len, build_int_cst (TREE_TYPE (len), 0));
1466 tmp = gfc_call_free (var);
1467 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1468 gfc_add_expr_to_block (&se->post, tmp);
1471 se->string_length = len;
1475 /* Return a character string containing the tty name. */
1478 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1486 unsigned int num_args;
1488 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1489 args = XALLOCAVEC (tree, num_args);
1491 var = gfc_create_var (pchar_type_node, "pstr");
1492 len = gfc_create_var (gfc_charlen_type_node, "len");
1494 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1495 args[0] = gfc_build_addr_expr (NULL_TREE, var);
1496 args[1] = gfc_build_addr_expr (NULL_TREE, len);
1498 fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
1499 tmp = build_call_array_loc (input_location,
1500 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
1501 fndecl, num_args, args);
1502 gfc_add_expr_to_block (&se->pre, tmp);
1504 /* Free the temporary afterwards, if necessary. */
1505 cond = fold_build2 (GT_EXPR, boolean_type_node,
1506 len, build_int_cst (TREE_TYPE (len), 0));
1507 tmp = gfc_call_free (var);
1508 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1509 gfc_add_expr_to_block (&se->post, tmp);
1512 se->string_length = len;
1516 /* Get the minimum/maximum value of all the parameters.
1517 minmax (a1, a2, a3, ...)
1520 if (a2 .op. mvar || isnan(mvar))
1522 if (a3 .op. mvar || isnan(mvar))
1529 /* TODO: Mismatching types can occur when specific names are used.
1530 These should be handled during resolution. */
1532 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
1540 gfc_actual_arglist *argexpr;
1541 unsigned int i, nargs;
1543 nargs = gfc_intrinsic_argument_list_length (expr);
1544 args = XALLOCAVEC (tree, nargs);
1546 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
1547 type = gfc_typenode_for_spec (&expr->ts);
1549 argexpr = expr->value.function.actual;
1550 if (TREE_TYPE (args[0]) != type)
1551 args[0] = convert (type, args[0]);
1552 /* Only evaluate the argument once. */
1553 if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
1554 args[0] = gfc_evaluate_now (args[0], &se->pre);
1556 mvar = gfc_create_var (type, "M");
1557 gfc_add_modify (&se->pre, mvar, args[0]);
1558 for (i = 1, argexpr = argexpr->next; i < nargs; i++)
1564 /* Handle absent optional arguments by ignoring the comparison. */
1565 if (argexpr->expr->expr_type == EXPR_VARIABLE
1566 && argexpr->expr->symtree->n.sym->attr.optional
1567 && TREE_CODE (val) == INDIRECT_REF)
1568 cond = fold_build2_loc (input_location,
1569 NE_EXPR, boolean_type_node,
1570 TREE_OPERAND (val, 0),
1571 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
1576 /* Only evaluate the argument once. */
1577 if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1578 val = gfc_evaluate_now (val, &se->pre);
1581 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1583 tmp = fold_build2 (op, boolean_type_node, convert (type, val), mvar);
1585 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1586 __builtin_isnan might be made dependent on that module being loaded,
1587 to help performance of programs that don't rely on IEEE semantics. */
1588 if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
1590 isnan = build_call_expr_loc (input_location,
1591 built_in_decls[BUILT_IN_ISNAN], 1, mvar);
1592 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
1593 fold_convert (boolean_type_node, isnan));
1595 tmp = build3_v (COND_EXPR, tmp, thencase,
1596 build_empty_stmt (input_location));
1598 if (cond != NULL_TREE)
1599 tmp = build3_v (COND_EXPR, cond, tmp,
1600 build_empty_stmt (input_location));
1602 gfc_add_expr_to_block (&se->pre, tmp);
1603 argexpr = argexpr->next;
1609 /* Generate library calls for MIN and MAX intrinsics for character
1612 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
1615 tree var, len, fndecl, tmp, cond, function;
1618 nargs = gfc_intrinsic_argument_list_length (expr);
1619 args = XALLOCAVEC (tree, nargs + 4);
1620 gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
1622 /* Create the result variables. */
1623 len = gfc_create_var (gfc_charlen_type_node, "len");
1624 args[0] = gfc_build_addr_expr (NULL_TREE, len);
1625 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
1626 args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
1627 args[2] = build_int_cst (NULL_TREE, op);
1628 args[3] = build_int_cst (NULL_TREE, nargs / 2);
1630 if (expr->ts.kind == 1)
1631 function = gfor_fndecl_string_minmax;
1632 else if (expr->ts.kind == 4)
1633 function = gfor_fndecl_string_minmax_char4;
1637 /* Make the function call. */
1638 fndecl = build_addr (function, current_function_decl);
1639 tmp = build_call_array_loc (input_location,
1640 TREE_TYPE (TREE_TYPE (function)), fndecl,
1642 gfc_add_expr_to_block (&se->pre, tmp);
1644 /* Free the temporary afterwards, if necessary. */
1645 cond = fold_build2 (GT_EXPR, boolean_type_node,
1646 len, build_int_cst (TREE_TYPE (len), 0));
1647 tmp = gfc_call_free (var);
1648 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1649 gfc_add_expr_to_block (&se->post, tmp);
1652 se->string_length = len;
1656 /* Create a symbol node for this intrinsic. The symbol from the frontend
1657 has the generic name. */
1660 gfc_get_symbol_for_expr (gfc_expr * expr)
1664 /* TODO: Add symbols for intrinsic function to the global namespace. */
1665 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1666 sym = gfc_new_symbol (expr->value.function.name, NULL);
1669 sym->attr.external = 1;
1670 sym->attr.function = 1;
1671 sym->attr.always_explicit = 1;
1672 sym->attr.proc = PROC_INTRINSIC;
1673 sym->attr.flavor = FL_PROCEDURE;
1677 sym->attr.dimension = 1;
1678 sym->as = gfc_get_array_spec ();
1679 sym->as->type = AS_ASSUMED_SHAPE;
1680 sym->as->rank = expr->rank;
1683 gfc_copy_formal_args_intr (sym, expr->value.function.isym);
1688 /* Generate a call to an external intrinsic function. */
1690 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1693 VEC(tree,gc) *append_args;
1695 gcc_assert (!se->ss || se->ss->expr == expr);
1698 gcc_assert (expr->rank > 0);
1700 gcc_assert (expr->rank == 0);
1702 sym = gfc_get_symbol_for_expr (expr);
1704 /* Calls to libgfortran_matmul need to be appended special arguments,
1705 to be able to call the BLAS ?gemm functions if required and possible. */
1707 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
1708 && sym->ts.type != BT_LOGICAL)
1710 tree cint = gfc_get_int_type (gfc_c_int_kind);
1712 if (gfc_option.flag_external_blas
1713 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1714 && (sym->ts.kind == gfc_default_real_kind
1715 || sym->ts.kind == gfc_default_double_kind))
1719 if (sym->ts.type == BT_REAL)
1721 if (sym->ts.kind == gfc_default_real_kind)
1722 gemm_fndecl = gfor_fndecl_sgemm;
1724 gemm_fndecl = gfor_fndecl_dgemm;
1728 if (sym->ts.kind == gfc_default_real_kind)
1729 gemm_fndecl = gfor_fndecl_cgemm;
1731 gemm_fndecl = gfor_fndecl_zgemm;
1734 append_args = VEC_alloc (tree, gc, 3);
1735 VEC_quick_push (tree, append_args, build_int_cst (cint, 1));
1736 VEC_quick_push (tree, append_args,
1737 build_int_cst (cint, gfc_option.blas_matmul_limit));
1738 VEC_quick_push (tree, append_args,
1739 gfc_build_addr_expr (NULL_TREE, gemm_fndecl));
1743 append_args = VEC_alloc (tree, gc, 3);
1744 VEC_quick_push (tree, append_args, build_int_cst (cint, 0));
1745 VEC_quick_push (tree, append_args, build_int_cst (cint, 0));
1746 VEC_quick_push (tree, append_args, null_pointer_node);
1750 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
1755 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1775 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
1784 gfc_actual_arglist *actual;
1791 gfc_conv_intrinsic_funcall (se, expr);
1795 actual = expr->value.function.actual;
1796 type = gfc_typenode_for_spec (&expr->ts);
1797 /* Initialize the result. */
1798 resvar = gfc_create_var (type, "test");
1800 tmp = convert (type, boolean_true_node);
1802 tmp = convert (type, boolean_false_node);
1803 gfc_add_modify (&se->pre, resvar, tmp);
1805 /* Walk the arguments. */
1806 arrayss = gfc_walk_expr (actual->expr);
1807 gcc_assert (arrayss != gfc_ss_terminator);
1809 /* Initialize the scalarizer. */
1810 gfc_init_loopinfo (&loop);
1811 exit_label = gfc_build_label_decl (NULL_TREE);
1812 TREE_USED (exit_label) = 1;
1813 gfc_add_ss_to_loop (&loop, arrayss);
1815 /* Initialize the loop. */
1816 gfc_conv_ss_startstride (&loop);
1817 gfc_conv_loop_setup (&loop, &expr->where);
1819 gfc_mark_ss_chain_used (arrayss, 1);
1820 /* Generate the loop body. */
1821 gfc_start_scalarized_body (&loop, &body);
1823 /* If the condition matches then set the return value. */
1824 gfc_start_block (&block);
1826 tmp = convert (type, boolean_false_node);
1828 tmp = convert (type, boolean_true_node);
1829 gfc_add_modify (&block, resvar, tmp);
1831 /* And break out of the loop. */
1832 tmp = build1_v (GOTO_EXPR, exit_label);
1833 gfc_add_expr_to_block (&block, tmp);
1835 found = gfc_finish_block (&block);
1837 /* Check this element. */
1838 gfc_init_se (&arrayse, NULL);
1839 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1840 arrayse.ss = arrayss;
1841 gfc_conv_expr_val (&arrayse, actual->expr);
1843 gfc_add_block_to_block (&body, &arrayse.pre);
1844 tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
1845 build_int_cst (TREE_TYPE (arrayse.expr), 0));
1846 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
1847 gfc_add_expr_to_block (&body, tmp);
1848 gfc_add_block_to_block (&body, &arrayse.post);
1850 gfc_trans_scalarizing_loops (&loop, &body);
1852 /* Add the exit label. */
1853 tmp = build1_v (LABEL_EXPR, exit_label);
1854 gfc_add_expr_to_block (&loop.pre, tmp);
1856 gfc_add_block_to_block (&se->pre, &loop.pre);
1857 gfc_add_block_to_block (&se->pre, &loop.post);
1858 gfc_cleanup_loop (&loop);
1863 /* COUNT(A) = Number of true elements in A. */
1865 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1872 gfc_actual_arglist *actual;
1878 gfc_conv_intrinsic_funcall (se, expr);
1882 actual = expr->value.function.actual;
1884 type = gfc_typenode_for_spec (&expr->ts);
1885 /* Initialize the result. */
1886 resvar = gfc_create_var (type, "count");
1887 gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
1889 /* Walk the arguments. */
1890 arrayss = gfc_walk_expr (actual->expr);
1891 gcc_assert (arrayss != gfc_ss_terminator);
1893 /* Initialize the scalarizer. */
1894 gfc_init_loopinfo (&loop);
1895 gfc_add_ss_to_loop (&loop, arrayss);
1897 /* Initialize the loop. */
1898 gfc_conv_ss_startstride (&loop);
1899 gfc_conv_loop_setup (&loop, &expr->where);
1901 gfc_mark_ss_chain_used (arrayss, 1);
1902 /* Generate the loop body. */
1903 gfc_start_scalarized_body (&loop, &body);
1905 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (resvar),
1906 resvar, build_int_cst (TREE_TYPE (resvar), 1));
1907 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1909 gfc_init_se (&arrayse, NULL);
1910 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1911 arrayse.ss = arrayss;
1912 gfc_conv_expr_val (&arrayse, actual->expr);
1913 tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
1914 build_empty_stmt (input_location));
1916 gfc_add_block_to_block (&body, &arrayse.pre);
1917 gfc_add_expr_to_block (&body, tmp);
1918 gfc_add_block_to_block (&body, &arrayse.post);
1920 gfc_trans_scalarizing_loops (&loop, &body);
1922 gfc_add_block_to_block (&se->pre, &loop.pre);
1923 gfc_add_block_to_block (&se->pre, &loop.post);
1924 gfc_cleanup_loop (&loop);
1929 /* Inline implementation of the sum and product intrinsics. */
1931 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
1935 tree scale = NULL_TREE;
1941 gfc_actual_arglist *actual;
1946 gfc_expr *arrayexpr;
1951 gfc_conv_intrinsic_funcall (se, expr);
1955 type = gfc_typenode_for_spec (&expr->ts);
1956 /* Initialize the result. */
1957 resvar = gfc_create_var (type, "val");
1962 scale = gfc_create_var (type, "scale");
1963 gfc_add_modify (&se->pre, scale,
1964 gfc_build_const (type, integer_one_node));
1965 tmp = gfc_build_const (type, integer_zero_node);
1967 else if (op == PLUS_EXPR)
1968 tmp = gfc_build_const (type, integer_zero_node);
1969 else if (op == NE_EXPR)
1971 tmp = convert (type, boolean_false_node);
1973 tmp = gfc_build_const (type, integer_one_node);
1975 gfc_add_modify (&se->pre, resvar, tmp);
1977 /* Walk the arguments. */
1978 actual = expr->value.function.actual;
1979 arrayexpr = actual->expr;
1980 arrayss = gfc_walk_expr (arrayexpr);
1981 gcc_assert (arrayss != gfc_ss_terminator);
1983 if (op == NE_EXPR || norm2)
1984 /* PARITY and NORM2. */
1988 actual = actual->next->next;
1989 gcc_assert (actual);
1990 maskexpr = actual->expr;
1993 if (maskexpr && maskexpr->rank != 0)
1995 maskss = gfc_walk_expr (maskexpr);
1996 gcc_assert (maskss != gfc_ss_terminator);
2001 /* Initialize the scalarizer. */
2002 gfc_init_loopinfo (&loop);
2003 gfc_add_ss_to_loop (&loop, arrayss);
2005 gfc_add_ss_to_loop (&loop, maskss);
2007 /* Initialize the loop. */
2008 gfc_conv_ss_startstride (&loop);
2009 gfc_conv_loop_setup (&loop, &expr->where);
2011 gfc_mark_ss_chain_used (arrayss, 1);
2013 gfc_mark_ss_chain_used (maskss, 1);
2014 /* Generate the loop body. */
2015 gfc_start_scalarized_body (&loop, &body);
2017 /* If we have a mask, only add this element if the mask is set. */
2020 gfc_init_se (&maskse, NULL);
2021 gfc_copy_loopinfo_to_se (&maskse, &loop);
2023 gfc_conv_expr_val (&maskse, maskexpr);
2024 gfc_add_block_to_block (&body, &maskse.pre);
2026 gfc_start_block (&block);
2029 gfc_init_block (&block);
2031 /* Do the actual summation/product. */
2032 gfc_init_se (&arrayse, NULL);
2033 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2034 arrayse.ss = arrayss;
2035 gfc_conv_expr_val (&arrayse, arrayexpr);
2036 gfc_add_block_to_block (&block, &arrayse.pre);
2046 result = 1.0 + result * val * val;
2052 result += val * val;
2055 tree res1, res2, cond, absX, val;
2056 stmtblock_t ifblock1, ifblock2, ifblock3;
2058 gfc_init_block (&ifblock1);
2060 absX = gfc_create_var (type, "absX");
2061 gfc_add_modify (&ifblock1, absX,
2062 fold_build1 (ABS_EXPR, type, arrayse.expr));
2063 val = gfc_create_var (type, "val");
2064 gfc_add_expr_to_block (&ifblock1, val);
2066 gfc_init_block (&ifblock2);
2067 gfc_add_modify (&ifblock2, val,
2068 fold_build2 (RDIV_EXPR, type, scale, absX));
2069 res1 = fold_build2 (MULT_EXPR, type, val, val);
2070 res1 = fold_build2 (MULT_EXPR, type, resvar, res1);
2071 res1 = fold_build2 (PLUS_EXPR, type, res1,
2072 gfc_build_const (type, integer_one_node));
2073 gfc_add_modify (&ifblock2, resvar, res1);
2074 gfc_add_modify (&ifblock2, scale, absX);
2075 res1 = gfc_finish_block (&ifblock2);
2077 gfc_init_block (&ifblock3);
2078 gfc_add_modify (&ifblock3, val,
2079 fold_build2 (RDIV_EXPR, type, absX, scale));
2080 res2 = fold_build2 (MULT_EXPR, type, val, val);
2081 res2 = fold_build2 (PLUS_EXPR, type, resvar, res2);
2082 gfc_add_modify (&ifblock3, resvar, res2);
2083 res2 = gfc_finish_block (&ifblock3);
2085 cond = fold_build2 (GT_EXPR, boolean_type_node, absX, scale);
2086 tmp = build3_v (COND_EXPR, cond, res1, res2);
2087 gfc_add_expr_to_block (&ifblock1, tmp);
2088 tmp = gfc_finish_block (&ifblock1);
2090 cond = fold_build2 (NE_EXPR, boolean_type_node, arrayse.expr,
2091 gfc_build_const (type, integer_zero_node));
2093 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2094 gfc_add_expr_to_block (&block, tmp);
2098 tmp = fold_build2 (op, type, resvar, arrayse.expr);
2099 gfc_add_modify (&block, resvar, tmp);
2102 gfc_add_block_to_block (&block, &arrayse.post);
2106 /* We enclose the above in if (mask) {...} . */
2108 tmp = gfc_finish_block (&block);
2109 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2110 build_empty_stmt (input_location));
2113 tmp = gfc_finish_block (&block);
2114 gfc_add_expr_to_block (&body, tmp);
2116 gfc_trans_scalarizing_loops (&loop, &body);
2118 /* For a scalar mask, enclose the loop in an if statement. */
2119 if (maskexpr && maskss == NULL)
2121 gfc_init_se (&maskse, NULL);
2122 gfc_conv_expr_val (&maskse, maskexpr);
2123 gfc_init_block (&block);
2124 gfc_add_block_to_block (&block, &loop.pre);
2125 gfc_add_block_to_block (&block, &loop.post);
2126 tmp = gfc_finish_block (&block);
2128 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2129 build_empty_stmt (input_location));
2130 gfc_add_expr_to_block (&block, tmp);
2131 gfc_add_block_to_block (&se->pre, &block);
2135 gfc_add_block_to_block (&se->pre, &loop.pre);
2136 gfc_add_block_to_block (&se->pre, &loop.post);
2139 gfc_cleanup_loop (&loop);
2143 /* result = scale * sqrt(result). */
2145 sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
2146 resvar = build_call_expr_loc (input_location,
2148 resvar = fold_build2 (MULT_EXPR, type, scale, resvar);
2155 /* Inline implementation of the dot_product intrinsic. This function
2156 is based on gfc_conv_intrinsic_arith (the previous function). */
2158 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2166 gfc_actual_arglist *actual;
2167 gfc_ss *arrayss1, *arrayss2;
2168 gfc_se arrayse1, arrayse2;
2169 gfc_expr *arrayexpr1, *arrayexpr2;
2171 type = gfc_typenode_for_spec (&expr->ts);
2173 /* Initialize the result. */
2174 resvar = gfc_create_var (type, "val");
2175 if (expr->ts.type == BT_LOGICAL)
2176 tmp = build_int_cst (type, 0);
2178 tmp = gfc_build_const (type, integer_zero_node);
2180 gfc_add_modify (&se->pre, resvar, tmp);
2182 /* Walk argument #1. */
2183 actual = expr->value.function.actual;
2184 arrayexpr1 = actual->expr;
2185 arrayss1 = gfc_walk_expr (arrayexpr1);
2186 gcc_assert (arrayss1 != gfc_ss_terminator);
2188 /* Walk argument #2. */
2189 actual = actual->next;
2190 arrayexpr2 = actual->expr;
2191 arrayss2 = gfc_walk_expr (arrayexpr2);
2192 gcc_assert (arrayss2 != gfc_ss_terminator);
2194 /* Initialize the scalarizer. */
2195 gfc_init_loopinfo (&loop);
2196 gfc_add_ss_to_loop (&loop, arrayss1);
2197 gfc_add_ss_to_loop (&loop, arrayss2);
2199 /* Initialize the loop. */
2200 gfc_conv_ss_startstride (&loop);
2201 gfc_conv_loop_setup (&loop, &expr->where);
2203 gfc_mark_ss_chain_used (arrayss1, 1);
2204 gfc_mark_ss_chain_used (arrayss2, 1);
2206 /* Generate the loop body. */
2207 gfc_start_scalarized_body (&loop, &body);
2208 gfc_init_block (&block);
2210 /* Make the tree expression for [conjg(]array1[)]. */
2211 gfc_init_se (&arrayse1, NULL);
2212 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2213 arrayse1.ss = arrayss1;
2214 gfc_conv_expr_val (&arrayse1, arrayexpr1);
2215 if (expr->ts.type == BT_COMPLEX)
2216 arrayse1.expr = fold_build1 (CONJ_EXPR, type, arrayse1.expr);
2217 gfc_add_block_to_block (&block, &arrayse1.pre);
2219 /* Make the tree expression for array2. */
2220 gfc_init_se (&arrayse2, NULL);
2221 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2222 arrayse2.ss = arrayss2;
2223 gfc_conv_expr_val (&arrayse2, arrayexpr2);
2224 gfc_add_block_to_block (&block, &arrayse2.pre);
2226 /* Do the actual product and sum. */
2227 if (expr->ts.type == BT_LOGICAL)
2229 tmp = fold_build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
2230 tmp = fold_build2 (TRUTH_OR_EXPR, type, resvar, tmp);
2234 tmp = fold_build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
2235 tmp = fold_build2 (PLUS_EXPR, type, resvar, tmp);
2237 gfc_add_modify (&block, resvar, tmp);
2239 /* Finish up the loop block and the loop. */
2240 tmp = gfc_finish_block (&block);
2241 gfc_add_expr_to_block (&body, tmp);
2243 gfc_trans_scalarizing_loops (&loop, &body);
2244 gfc_add_block_to_block (&se->pre, &loop.pre);
2245 gfc_add_block_to_block (&se->pre, &loop.post);
2246 gfc_cleanup_loop (&loop);
2252 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2253 we need to handle. For performance reasons we sometimes create two
2254 loops instead of one, where the second one is much simpler.
2255 Examples for minloc intrinsic:
2256 1) Result is an array, a call is generated
2257 2) Array mask is used and NaNs need to be supported:
2263 if (pos == 0) pos = S + (1 - from);
2264 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2271 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2275 3) NaNs need to be supported, but it is known at compile time or cheaply
2276 at runtime whether array is nonempty or not:
2281 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2284 if (from <= to) pos = 1;
2288 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2292 4) NaNs aren't supported, array mask is used:
2293 limit = infinities_supported ? Infinity : huge (limit);
2297 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2303 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2307 5) Same without array mask:
2308 limit = infinities_supported ? Infinity : huge (limit);
2309 pos = (from <= to) ? 1 : 0;
2312 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2315 For 3) and 5), if mask is scalar, this all goes into a conditional,
2316 setting pos = 0; in the else branch. */
2319 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
2323 stmtblock_t ifblock;
2324 stmtblock_t elseblock;
2335 gfc_actual_arglist *actual;
2340 gfc_expr *arrayexpr;
2347 gfc_conv_intrinsic_funcall (se, expr);
2351 /* Initialize the result. */
2352 pos = gfc_create_var (gfc_array_index_type, "pos");
2353 offset = gfc_create_var (gfc_array_index_type, "offset");
2354 type = gfc_typenode_for_spec (&expr->ts);
2356 /* Walk the arguments. */
2357 actual = expr->value.function.actual;
2358 arrayexpr = actual->expr;
2359 arrayss = gfc_walk_expr (arrayexpr);
2360 gcc_assert (arrayss != gfc_ss_terminator);
2362 actual = actual->next->next;
2363 gcc_assert (actual);
2364 maskexpr = actual->expr;
2366 if (maskexpr && maskexpr->rank != 0)
2368 maskss = gfc_walk_expr (maskexpr);
2369 gcc_assert (maskss != gfc_ss_terminator);
2374 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
2376 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
2378 nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
2379 gfc_index_zero_node);
2384 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2385 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2386 switch (arrayexpr->ts.type)
2389 if (HONOR_INFINITIES (DECL_MODE (limit)))
2391 REAL_VALUE_TYPE real;
2393 tmp = build_real (TREE_TYPE (limit), real);
2396 tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2397 arrayexpr->ts.kind, 0);
2401 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2402 arrayexpr->ts.kind);
2409 /* We start with the most negative possible value for MAXLOC, and the most
2410 positive possible value for MINLOC. The most negative possible value is
2411 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2412 possible value is HUGE in both cases. */
2414 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2415 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2416 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2417 build_int_cst (type, 1));
2419 gfc_add_modify (&se->pre, limit, tmp);
2421 /* Initialize the scalarizer. */
2422 gfc_init_loopinfo (&loop);
2423 gfc_add_ss_to_loop (&loop, arrayss);
2425 gfc_add_ss_to_loop (&loop, maskss);
2427 /* Initialize the loop. */
2428 gfc_conv_ss_startstride (&loop);
2429 gfc_conv_loop_setup (&loop, &expr->where);
2431 gcc_assert (loop.dimen == 1);
2432 if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
2433 nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
2438 /* Initialize the position to zero, following Fortran 2003. We are free
2439 to do this because Fortran 95 allows the result of an entirely false
2440 mask to be processor dependent. If we know at compile time the array
2441 is non-empty and no MASK is used, we can initialize to 1 to simplify
2443 if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
2444 gfc_add_modify (&loop.pre, pos,
2445 fold_build3 (COND_EXPR, gfc_array_index_type,
2446 nonempty, gfc_index_one_node,
2447 gfc_index_zero_node));
2450 gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
2451 lab1 = gfc_build_label_decl (NULL_TREE);
2452 TREE_USED (lab1) = 1;
2453 lab2 = gfc_build_label_decl (NULL_TREE);
2454 TREE_USED (lab2) = 1;
2457 gfc_mark_ss_chain_used (arrayss, 1);
2459 gfc_mark_ss_chain_used (maskss, 1);
2460 /* Generate the loop body. */
2461 gfc_start_scalarized_body (&loop, &body);
2463 /* If we have a mask, only check this element if the mask is set. */
2466 gfc_init_se (&maskse, NULL);
2467 gfc_copy_loopinfo_to_se (&maskse, &loop);
2469 gfc_conv_expr_val (&maskse, maskexpr);
2470 gfc_add_block_to_block (&body, &maskse.pre);
2472 gfc_start_block (&block);
2475 gfc_init_block (&block);
2477 /* Compare with the current limit. */
2478 gfc_init_se (&arrayse, NULL);
2479 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2480 arrayse.ss = arrayss;
2481 gfc_conv_expr_val (&arrayse, arrayexpr);
2482 gfc_add_block_to_block (&block, &arrayse.pre);
2484 /* We do the following if this is a more extreme value. */
2485 gfc_start_block (&ifblock);
2487 /* Assign the value to the limit... */
2488 gfc_add_modify (&ifblock, limit, arrayse.expr);
2490 /* Remember where we are. An offset must be added to the loop
2491 counter to obtain the required position. */
2493 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2494 gfc_index_one_node, loop.from[0]);
2496 tmp = gfc_index_one_node;
2498 gfc_add_modify (&block, offset, tmp);
2500 if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
2502 stmtblock_t ifblock2;
2505 gfc_start_block (&ifblock2);
2506 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2507 loop.loopvar[0], offset);
2508 gfc_add_modify (&ifblock2, pos, tmp);
2509 ifbody2 = gfc_finish_block (&ifblock2);
2510 cond = fold_build2 (EQ_EXPR, boolean_type_node, pos,
2511 gfc_index_zero_node);
2512 tmp = build3_v (COND_EXPR, cond, ifbody2,
2513 build_empty_stmt (input_location));
2514 gfc_add_expr_to_block (&block, tmp);
2517 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2518 loop.loopvar[0], offset);
2519 gfc_add_modify (&ifblock, pos, tmp);
2522 gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
2524 ifbody = gfc_finish_block (&ifblock);
2526 if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
2529 cond = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
2530 boolean_type_node, arrayse.expr, limit);
2532 cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2534 ifbody = build3_v (COND_EXPR, cond, ifbody,
2535 build_empty_stmt (input_location));
2537 gfc_add_expr_to_block (&block, ifbody);
2541 /* We enclose the above in if (mask) {...}. */
2542 tmp = gfc_finish_block (&block);
2544 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2545 build_empty_stmt (input_location));
2548 tmp = gfc_finish_block (&block);
2549 gfc_add_expr_to_block (&body, tmp);
2553 gfc_trans_scalarized_loop_end (&loop, 0, &body);
2555 if (HONOR_NANS (DECL_MODE (limit)))
2557 if (nonempty != NULL)
2559 ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
2560 tmp = build3_v (COND_EXPR, nonempty, ifbody,
2561 build_empty_stmt (input_location));
2562 gfc_add_expr_to_block (&loop.code[0], tmp);
2566 gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
2567 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
2568 gfc_start_block (&body);
2570 /* If we have a mask, only check this element if the mask is set. */
2573 gfc_init_se (&maskse, NULL);
2574 gfc_copy_loopinfo_to_se (&maskse, &loop);
2576 gfc_conv_expr_val (&maskse, maskexpr);
2577 gfc_add_block_to_block (&body, &maskse.pre);
2579 gfc_start_block (&block);
2582 gfc_init_block (&block);
2584 /* Compare with the current limit. */
2585 gfc_init_se (&arrayse, NULL);
2586 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2587 arrayse.ss = arrayss;
2588 gfc_conv_expr_val (&arrayse, arrayexpr);
2589 gfc_add_block_to_block (&block, &arrayse.pre);
2591 /* We do the following if this is a more extreme value. */
2592 gfc_start_block (&ifblock);
2594 /* Assign the value to the limit... */
2595 gfc_add_modify (&ifblock, limit, arrayse.expr);
2597 /* Remember where we are. An offset must be added to the loop
2598 counter to obtain the required position. */
2600 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2601 gfc_index_one_node, loop.from[0]);
2603 tmp = gfc_index_one_node;
2605 gfc_add_modify (&block, offset, tmp);
2607 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2608 loop.loopvar[0], offset);
2609 gfc_add_modify (&ifblock, pos, tmp);
2611 ifbody = gfc_finish_block (&ifblock);
2613 cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2615 tmp = build3_v (COND_EXPR, cond, ifbody,
2616 build_empty_stmt (input_location));
2617 gfc_add_expr_to_block (&block, tmp);
2621 /* We enclose the above in if (mask) {...}. */
2622 tmp = gfc_finish_block (&block);
2624 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2625 build_empty_stmt (input_location));
2628 tmp = gfc_finish_block (&block);
2629 gfc_add_expr_to_block (&body, tmp);
2630 /* Avoid initializing loopvar[0] again, it should be left where
2631 it finished by the first loop. */
2632 loop.from[0] = loop.loopvar[0];
2635 gfc_trans_scalarizing_loops (&loop, &body);
2638 gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
2640 /* For a scalar mask, enclose the loop in an if statement. */
2641 if (maskexpr && maskss == NULL)
2643 gfc_init_se (&maskse, NULL);
2644 gfc_conv_expr_val (&maskse, maskexpr);
2645 gfc_init_block (&block);
2646 gfc_add_block_to_block (&block, &loop.pre);
2647 gfc_add_block_to_block (&block, &loop.post);
2648 tmp = gfc_finish_block (&block);
2650 /* For the else part of the scalar mask, just initialize
2651 the pos variable the same way as above. */
2653 gfc_init_block (&elseblock);
2654 gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
2655 elsetmp = gfc_finish_block (&elseblock);
2657 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2658 gfc_add_expr_to_block (&block, tmp);
2659 gfc_add_block_to_block (&se->pre, &block);
2663 gfc_add_block_to_block (&se->pre, &loop.pre);
2664 gfc_add_block_to_block (&se->pre, &loop.post);
2666 gfc_cleanup_loop (&loop);
2668 se->expr = convert (type, pos);
2671 /* Emit code for minval or maxval intrinsic. There are many different cases
2672 we need to handle. For performance reasons we sometimes create two
2673 loops instead of one, where the second one is much simpler.
2674 Examples for minval intrinsic:
2675 1) Result is an array, a call is generated
2676 2) Array mask is used and NaNs need to be supported, rank 1:
2681 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
2684 limit = nonempty ? NaN : huge (limit);
2686 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
2687 3) NaNs need to be supported, but it is known at compile time or cheaply
2688 at runtime whether array is nonempty or not, rank 1:
2691 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
2692 limit = (from <= to) ? NaN : huge (limit);
2694 while (S <= to) { limit = min (a[S], limit); S++; }
2695 4) Array mask is used and NaNs need to be supported, rank > 1:
2704 if (fast) limit = min (a[S1][S2], limit);
2707 if (a[S1][S2] <= limit) {
2718 limit = nonempty ? NaN : huge (limit);
2719 5) NaNs need to be supported, but it is known at compile time or cheaply
2720 at runtime whether array is nonempty or not, rank > 1:
2727 if (fast) limit = min (a[S1][S2], limit);
2729 if (a[S1][S2] <= limit) {
2739 limit = (nonempty_array) ? NaN : huge (limit);
2740 6) NaNs aren't supported, but infinities are. Array mask is used:
2745 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
2748 limit = nonempty ? limit : huge (limit);
2749 7) Same without array mask:
2752 while (S <= to) { limit = min (a[S], limit); S++; }
2753 limit = (from <= to) ? limit : huge (limit);
2754 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
2755 limit = huge (limit);
2757 while (S <= to) { limit = min (a[S], limit); S++); }
2759 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
2760 with array mask instead).
2761 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
2762 setting limit = huge (limit); in the else branch. */
2765 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
2775 tree huge_cst = NULL, nan_cst = NULL;
2777 stmtblock_t block, block2;
2779 gfc_actual_arglist *actual;
2784 gfc_expr *arrayexpr;
2790 gfc_conv_intrinsic_funcall (se, expr);
2794 type = gfc_typenode_for_spec (&expr->ts);
2795 /* Initialize the result. */
2796 limit = gfc_create_var (type, "limit");
2797 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2798 switch (expr->ts.type)
2801 huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2803 if (HONOR_INFINITIES (DECL_MODE (limit)))
2805 REAL_VALUE_TYPE real;
2807 tmp = build_real (type, real);
2811 if (HONOR_NANS (DECL_MODE (limit)))
2813 REAL_VALUE_TYPE real;
2814 real_nan (&real, "", 1, DECL_MODE (limit));
2815 nan_cst = build_real (type, real);
2820 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2827 /* We start with the most negative possible value for MAXVAL, and the most
2828 positive possible value for MINVAL. The most negative possible value is
2829 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2830 possible value is HUGE in both cases. */
2833 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2835 huge_cst = fold_build1 (NEGATE_EXPR, TREE_TYPE (huge_cst), huge_cst);
2838 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2839 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp),
2840 tmp, build_int_cst (type, 1));
2842 gfc_add_modify (&se->pre, limit, tmp);
2844 /* Walk the arguments. */
2845 actual = expr->value.function.actual;
2846 arrayexpr = actual->expr;
2847 arrayss = gfc_walk_expr (arrayexpr);
2848 gcc_assert (arrayss != gfc_ss_terminator);
2850 actual = actual->next->next;
2851 gcc_assert (actual);
2852 maskexpr = actual->expr;
2854 if (maskexpr && maskexpr->rank != 0)
2856 maskss = gfc_walk_expr (maskexpr);
2857 gcc_assert (maskss != gfc_ss_terminator);
2862 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
2864 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
2866 nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
2867 gfc_index_zero_node);
2872 /* Initialize the scalarizer. */
2873 gfc_init_loopinfo (&loop);
2874 gfc_add_ss_to_loop (&loop, arrayss);
2876 gfc_add_ss_to_loop (&loop, maskss);
2878 /* Initialize the loop. */
2879 gfc_conv_ss_startstride (&loop);
2880 gfc_conv_loop_setup (&loop, &expr->where);
2882 if (nonempty == NULL && maskss == NULL
2883 && loop.dimen == 1 && loop.from[0] && loop.to[0])
2884 nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
2886 nonempty_var = NULL;
2887 if (nonempty == NULL
2888 && (HONOR_INFINITIES (DECL_MODE (limit))
2889 || HONOR_NANS (DECL_MODE (limit))))
2891 nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
2892 gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
2893 nonempty = nonempty_var;
2897 if (HONOR_NANS (DECL_MODE (limit)))
2899 if (loop.dimen == 1)
2901 lab = gfc_build_label_decl (NULL_TREE);
2902 TREE_USED (lab) = 1;
2906 fast = gfc_create_var (boolean_type_node, "fast");
2907 gfc_add_modify (&se->pre, fast, boolean_false_node);
2911 gfc_mark_ss_chain_used (arrayss, 1);
2913 gfc_mark_ss_chain_used (maskss, 1);
2914 /* Generate the loop body. */
2915 gfc_start_scalarized_body (&loop, &body);
2917 /* If we have a mask, only add this element if the mask is set. */
2920 gfc_init_se (&maskse, NULL);
2921 gfc_copy_loopinfo_to_se (&maskse, &loop);
2923 gfc_conv_expr_val (&maskse, maskexpr);
2924 gfc_add_block_to_block (&body, &maskse.pre);
2926 gfc_start_block (&block);
2929 gfc_init_block (&block);
2931 /* Compare with the current limit. */
2932 gfc_init_se (&arrayse, NULL);
2933 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2934 arrayse.ss = arrayss;
2935 gfc_conv_expr_val (&arrayse, arrayexpr);
2936 gfc_add_block_to_block (&block, &arrayse.pre);
2938 gfc_init_block (&block2);
2941 gfc_add_modify (&block2, nonempty_var, boolean_true_node);
2943 if (HONOR_NANS (DECL_MODE (limit)))
2945 tmp = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
2946 boolean_type_node, arrayse.expr, limit);
2948 ifbody = build1_v (GOTO_EXPR, lab);
2951 stmtblock_t ifblock;
2953 gfc_init_block (&ifblock);
2954 gfc_add_modify (&ifblock, limit, arrayse.expr);
2955 gfc_add_modify (&ifblock, fast, boolean_true_node);
2956 ifbody = gfc_finish_block (&ifblock);
2958 tmp = build3_v (COND_EXPR, tmp, ifbody,
2959 build_empty_stmt (input_location));
2960 gfc_add_expr_to_block (&block2, tmp);
2964 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2966 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2968 tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2969 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2970 tmp = build3_v (COND_EXPR, tmp, ifbody,
2971 build_empty_stmt (input_location));
2972 gfc_add_expr_to_block (&block2, tmp);
2976 tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2977 type, arrayse.expr, limit);
2978 gfc_add_modify (&block2, limit, tmp);
2984 tree elsebody = gfc_finish_block (&block2);
2986 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2988 if (HONOR_NANS (DECL_MODE (limit))
2989 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2991 tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2992 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2993 ifbody = build3_v (COND_EXPR, tmp, ifbody,
2994 build_empty_stmt (input_location));
2998 tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2999 type, arrayse.expr, limit);
3000 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
3002 tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
3003 gfc_add_expr_to_block (&block, tmp);
3006 gfc_add_block_to_block (&block, &block2);
3008 gfc_add_block_to_block (&block, &arrayse.post);
3010 tmp = gfc_finish_block (&block);
3012 /* We enclose the above in if (mask) {...}. */
3013 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3014 build_empty_stmt (input_location));
3015 gfc_add_expr_to_block (&body, tmp);
3019 gfc_trans_scalarized_loop_end (&loop, 0, &body);
3021 tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
3022 gfc_add_modify (&loop.code[0], limit, tmp);
3023 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
3025 gfc_start_block (&body);
3027 /* If we have a mask, only add this element if the mask is set. */
3030 gfc_init_se (&maskse, NULL);
3031 gfc_copy_loopinfo_to_se (&maskse, &loop);
3033 gfc_conv_expr_val (&maskse, maskexpr);
3034 gfc_add_block_to_block (&body, &maskse.pre);
3036 gfc_start_block (&block);
3039 gfc_init_block (&block);
3041 /* Compare with the current limit. */
3042 gfc_init_se (&arrayse, NULL);
3043 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3044 arrayse.ss = arrayss;
3045 gfc_conv_expr_val (&arrayse, arrayexpr);
3046 gfc_add_block_to_block (&block, &arrayse.pre);
3048 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3050 if (HONOR_NANS (DECL_MODE (limit))
3051 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3053 tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
3054 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3055 tmp = build3_v (COND_EXPR, tmp, ifbody,
3056 build_empty_stmt (input_location));
3057 gfc_add_expr_to_block (&block, tmp);
3061 tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3062 type, arrayse.expr, limit);
3063 gfc_add_modify (&block, limit, tmp);
3066 gfc_add_block_to_block (&block, &arrayse.post);
3068 tmp = gfc_finish_block (&block);
3070 /* We enclose the above in if (mask) {...}. */
3071 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3072 build_empty_stmt (input_location));
3073 gfc_add_expr_to_block (&body, tmp);
3074 /* Avoid initializing loopvar[0] again, it should be left where
3075 it finished by the first loop. */
3076 loop.from[0] = loop.loopvar[0];
3078 gfc_trans_scalarizing_loops (&loop, &body);
3082 tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
3083 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
3084 tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
3086 gfc_add_expr_to_block (&loop.pre, tmp);
3088 else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
3090 tmp = fold_build3 (COND_EXPR, type, nonempty, limit, huge_cst);
3091 gfc_add_modify (&loop.pre, limit, tmp);
3094 /* For a scalar mask, enclose the loop in an if statement. */
3095 if (maskexpr && maskss == NULL)
3099 gfc_init_se (&maskse, NULL);
3100 gfc_conv_expr_val (&maskse, maskexpr);
3101 gfc_init_block (&block);
3102 gfc_add_block_to_block (&block, &loop.pre);
3103 gfc_add_block_to_block (&block, &loop.post);
3104 tmp = gfc_finish_block (&block);
3106 if (HONOR_INFINITIES (DECL_MODE (limit)))
3107 else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
3109 else_stmt = build_empty_stmt (input_location);
3110 tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
3111 gfc_add_expr_to_block (&block, tmp);
3112 gfc_add_block_to_block (&se->pre, &block);
3116 gfc_add_block_to_block (&se->pre, &loop.pre);
3117 gfc_add_block_to_block (&se->pre, &loop.post);
3120 gfc_cleanup_loop (&loop);
3125 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3127 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
3133 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3134 type = TREE_TYPE (args[0]);
3136 tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
3137 tmp = fold_build2 (BIT_AND_EXPR, type, args[0], tmp);
3138 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
3139 build_int_cst (type, 0));
3140 type = gfc_typenode_for_spec (&expr->ts);
3141 se->expr = convert (type, tmp);
3144 /* Generate code to perform the specified operation. */
3146 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
3150 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3151 se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
3156 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
3160 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3161 se->expr = fold_build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
3164 /* Set or clear a single bit. */
3166 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
3173 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3174 type = TREE_TYPE (args[0]);
3176 tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
3182 tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
3184 se->expr = fold_build2 (op, type, args[0], tmp);
3187 /* Extract a sequence of bits.
3188 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3190 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
3197 gfc_conv_intrinsic_function_args (se, expr, args, 3);
3198 type = TREE_TYPE (args[0]);
3200 mask = build_int_cst (type, -1);
3201 mask = fold_build2 (LSHIFT_EXPR, type, mask, args[2]);
3202 mask = fold_build1 (BIT_NOT_EXPR, type, mask);
3204 tmp = fold_build2 (RSHIFT_EXPR, type, args[0], args[1]);
3206 se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
3209 /* RSHIFT (I, SHIFT) = I >> SHIFT
3210 LSHIFT (I, SHIFT) = I << SHIFT */
3212 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
3216 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3218 se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
3219 TREE_TYPE (args[0]), args[0], args[1]);
3222 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
3224 : ((shift >= 0) ? i << shift : i >> -shift)
3225 where all shifts are logical shifts. */
3227 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
3239 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3241 args[0] = gfc_evaluate_now (args[0], &se->pre);
3242 args[1] = gfc_evaluate_now (args[1], &se->pre);
3244 type = TREE_TYPE (args[0]);
3245 utype = unsigned_type_for (type);
3247 width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
3249 /* Left shift if positive. */
3250 lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
3252 /* Right shift if negative.
3253 We convert to an unsigned type because we want a logical shift.
3254 The standard doesn't define the case of shifting negative
3255 numbers, and we try to be compatible with other compilers, most
3256 notably g77, here. */
3257 rshift = fold_convert (type, fold_build2 (RSHIFT_EXPR, utype,
3258 convert (utype, args[0]), width));
3260 tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
3261 build_int_cst (TREE_TYPE (args[1]), 0));
3262 tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
3264 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3265 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3267 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
3268 cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
3270 se->expr = fold_build3 (COND_EXPR, type, cond,
3271 build_int_cst (type, 0), tmp);
3275 /* Circular shift. AKA rotate or barrel shift. */
3278 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
3286 unsigned int num_args;
3288 num_args = gfc_intrinsic_argument_list_length (expr);
3289 args = XALLOCAVEC (tree, num_args);
3291 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3295 /* Use a library function for the 3 parameter version. */
3296 tree int4type = gfc_get_int_type (4);
3298 type = TREE_TYPE (args[0]);
3299 /* We convert the first argument to at least 4 bytes, and
3300 convert back afterwards. This removes the need for library
3301 functions for all argument sizes, and function will be
3302 aligned to at least 32 bits, so there's no loss. */
3303 if (expr->ts.kind < 4)
3304 args[0] = convert (int4type, args[0]);
3306 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
3307 need loads of library functions. They cannot have values >
3308 BIT_SIZE (I) so the conversion is safe. */
3309 args[1] = convert (int4type, args[1]);
3310 args[2] = convert (int4type, args[2]);
3312 switch (expr->ts.kind)
3317 tmp = gfor_fndecl_math_ishftc4;
3320 tmp = gfor_fndecl_math_ishftc8;
3323 tmp = gfor_fndecl_math_ishftc16;
3328 se->expr = build_call_expr_loc (input_location,
3329 tmp, 3, args[0], args[1], args[2]);
3330 /* Convert the result back to the original type, if we extended
3331 the first argument's width above. */
3332 if (expr->ts.kind < 4)
3333 se->expr = convert (type, se->expr);
3337 type = TREE_TYPE (args[0]);
3339 /* Evaluate arguments only once. */
3340 args[0] = gfc_evaluate_now (args[0], &se->pre);
3341 args[1] = gfc_evaluate_now (args[1], &se->pre);
3343 /* Rotate left if positive. */
3344 lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
3346 /* Rotate right if negative. */
3347 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
3348 rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
3350 zero = build_int_cst (TREE_TYPE (args[1]), 0);
3351 tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
3352 rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
3354 /* Do nothing if shift == 0. */
3355 tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
3356 se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
3359 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
3360 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
3362 The conditional expression is necessary because the result of LEADZ(0)
3363 is defined, but the result of __builtin_clz(0) is undefined for most
3366 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
3367 difference in bit size between the argument of LEADZ and the C int. */
3370 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
3382 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3383 argsize = TYPE_PRECISION (TREE_TYPE (arg));
3385 /* Which variant of __builtin_clz* should we call? */
3386 if (argsize <= INT_TYPE_SIZE)
3388 arg_type = unsigned_type_node;
3389 func = built_in_decls[BUILT_IN_CLZ];
3391 else if (argsize <= LONG_TYPE_SIZE)
3393 arg_type = long_unsigned_type_node;
3394 func = built_in_decls[BUILT_IN_CLZL];
3396 else if (argsize <= LONG_LONG_TYPE_SIZE)
3398 arg_type = long_long_unsigned_type_node;
3399 func = built_in_decls[BUILT_IN_CLZLL];
3403 gcc_assert (argsize == 128);
3404 arg_type = gfc_build_uint_type (argsize);
3405 func = gfor_fndecl_clz128;
3408 /* Convert the actual argument twice: first, to the unsigned type of the
3409 same size; then, to the proper argument type for the built-in
3410 function. But the return type is of the default INTEGER kind. */
3411 arg = fold_convert (gfc_build_uint_type (argsize), arg);
3412 arg = fold_convert (arg_type, arg);
3413 result_type = gfc_get_int_type (gfc_default_integer_kind);
3415 /* Compute LEADZ for the case i .ne. 0. */
3416 s = TYPE_PRECISION (arg_type) - argsize;
3417 tmp = fold_convert (result_type, build_call_expr_loc (input_location, func,
3419 leadz = fold_build2 (MINUS_EXPR, result_type,
3420 tmp, build_int_cst (result_type, s));
3422 /* Build BIT_SIZE. */
3423 bit_size = build_int_cst (result_type, argsize);
3425 cond = fold_build2 (EQ_EXPR, boolean_type_node,
3426 arg, build_int_cst (arg_type, 0));
3427 se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz);
3430 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
3432 The conditional expression is necessary because the result of TRAILZ(0)
3433 is defined, but the result of __builtin_ctz(0) is undefined for most
3437 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
3448 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3449 argsize = TYPE_PRECISION (TREE_TYPE (arg));
3451 /* Which variant of __builtin_ctz* should we call? */
3452 if (argsize <= INT_TYPE_SIZE)
3454 arg_type = unsigned_type_node;
3455 func = built_in_decls[BUILT_IN_CTZ];
3457 else if (argsize <= LONG_TYPE_SIZE)
3459 arg_type = long_unsigned_type_node;
3460 func = built_in_decls[BUILT_IN_CTZL];
3462 else if (argsize <= LONG_LONG_TYPE_SIZE)
3464 arg_type = long_long_unsigned_type_node;
3465 func = built_in_decls[BUILT_IN_CTZLL];
3469 gcc_assert (argsize == 128);
3470 arg_type = gfc_build_uint_type (argsize);
3471 func = gfor_fndecl_ctz128;
3474 /* Convert the actual argument twice: first, to the unsigned type of the
3475 same size; then, to the proper argument type for the built-in
3476 function. But the return type is of the default INTEGER kind. */
3477 arg = fold_convert (gfc_build_uint_type (argsize), arg);
3478 arg = fold_convert (arg_type, arg);
3479 result_type = gfc_get_int_type (gfc_default_integer_kind);
3481 /* Compute TRAILZ for the case i .ne. 0. */
3482 trailz = fold_convert (result_type, build_call_expr_loc (input_location,
3485 /* Build BIT_SIZE. */
3486 bit_size = build_int_cst (result_type, argsize);
3488 cond = fold_build2 (EQ_EXPR, boolean_type_node,
3489 arg, build_int_cst (arg_type, 0));
3490 se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz);
3493 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
3494 for types larger than "long long", we call the long long built-in for
3495 the lower and higher bits and combine the result. */
3498 gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
3506 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3507 argsize = TYPE_PRECISION (TREE_TYPE (arg));
3508 result_type = gfc_get_int_type (gfc_default_integer_kind);
3510 /* Which variant of the builtin should we call? */
3511 if (argsize <= INT_TYPE_SIZE)
3513 arg_type = unsigned_type_node;
3514 func = built_in_decls[parity ? BUILT_IN_PARITY : BUILT_IN_POPCOUNT];
3516 else if (argsize <= LONG_TYPE_SIZE)
3518 arg_type = long_unsigned_type_node;
3519 func = built_in_decls[parity ? BUILT_IN_PARITYL : BUILT_IN_POPCOUNTL];
3521 else if (argsize <= LONG_LONG_TYPE_SIZE)
3523 arg_type = long_long_unsigned_type_node;
3524 func = built_in_decls[parity ? BUILT_IN_PARITYLL : BUILT_IN_POPCOUNTLL];
3528 /* Our argument type is larger than 'long long', which mean none
3529 of the POPCOUNT builtins covers it. We thus call the 'long long'
3530 variant multiple times, and add the results. */
3531 tree utype, arg2, call1, call2;
3533 /* For now, we only cover the case where argsize is twice as large
3535 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
3537 func = built_in_decls[parity ? BUILT_IN_PARITYLL : BUILT_IN_POPCOUNTLL];
3539 /* Convert it to an integer, and store into a variable. */
3540 utype = gfc_build_uint_type (argsize);
3541 arg = fold_convert (utype, arg);
3542 arg = gfc_evaluate_now (arg, &se->pre);
3544 /* Call the builtin twice. */
3545 call1 = build_call_expr_loc (input_location, func, 1,
3546 fold_convert (long_long_unsigned_type_node,
3549 arg2 = fold_build2 (RSHIFT_EXPR, utype, arg,
3550 build_int_cst (utype, LONG_LONG_TYPE_SIZE));
3551 call2 = build_call_expr_loc (input_location, func, 1,
3552 fold_convert (long_long_unsigned_type_node,
3555 /* Combine the results. */
3557 se->expr = fold_build2 (BIT_XOR_EXPR, result_type, call1, call2);
3559 se->expr = fold_build2 (PLUS_EXPR, result_type, call1, call2);
3564 /* Convert the actual argument twice: first, to the unsigned type of the
3565 same size; then, to the proper argument type for the built-in
3567 arg = fold_convert (gfc_build_uint_type (argsize), arg);
3568 arg = fold_convert (arg_type, arg);
3570 se->expr = fold_convert (result_type,
3571 build_call_expr_loc (input_location, func, 1, arg));
3575 /* Process an intrinsic with unspecified argument-types that has an optional
3576 argument (which could be of type character), e.g. EOSHIFT. For those, we
3577 need to append the string length of the optional argument if it is not
3578 present and the type is really character.
3579 primary specifies the position (starting at 1) of the non-optional argument
3580 specifying the type and optional gives the position of the optional
3581 argument in the arglist. */
3584 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
3585 unsigned primary, unsigned optional)
3587 gfc_actual_arglist* prim_arg;
3588 gfc_actual_arglist* opt_arg;
3590 gfc_actual_arglist* arg;
3592 VEC(tree,gc) *append_args;
3594 /* Find the two arguments given as position. */
3598 for (arg = expr->value.function.actual; arg; arg = arg->next)
3602 if (cur_pos == primary)
3604 if (cur_pos == optional)
3607 if (cur_pos >= primary && cur_pos >= optional)
3610 gcc_assert (prim_arg);
3611 gcc_assert (prim_arg->expr);
3612 gcc_assert (opt_arg);
3614 /* If we do have type CHARACTER and the optional argument is really absent,
3615 append a dummy 0 as string length. */
3617 if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
3621 dummy = build_int_cst (gfc_charlen_type_node, 0);
3622 append_args = VEC_alloc (tree, gc, 1);
3623 VEC_quick_push (tree, append_args, dummy);
3626 /* Build the call itself. */
3627 sym = gfc_get_symbol_for_expr (expr);
3628 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3634 /* The length of a character string. */
3636 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
3646 gcc_assert (!se->ss);
3648 arg = expr->value.function.actual->expr;
3650 type = gfc_typenode_for_spec (&expr->ts);
3651 switch (arg->expr_type)
3654 len = build_int_cst (NULL_TREE, arg->value.character.length);
3658 /* Obtain the string length from the function used by
3659 trans-array.c(gfc_trans_array_constructor). */
3661 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
3665 if (arg->ref == NULL
3666 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
3668 /* This doesn't catch all cases.
3669 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
3670 and the surrounding thread. */
3671 sym = arg->symtree->n.sym;
3672 decl = gfc_get_symbol_decl (sym);
3673 if (decl == current_function_decl && sym->attr.function
3674 && (sym->result == sym))
3675 decl = gfc_get_fake_result_decl (sym, 0);
3677 len = sym->ts.u.cl->backend_decl;
3682 /* Otherwise fall through. */
3685 /* Anybody stupid enough to do this deserves inefficient code. */
3686 ss = gfc_walk_expr (arg);
3687 gfc_init_se (&argse, se);
3688 if (ss == gfc_ss_terminator)
3689 gfc_conv_expr (&argse, arg);
3691 gfc_conv_expr_descriptor (&argse, arg, ss);
3692 gfc_add_block_to_block (&se->pre, &argse.pre);
3693 gfc_add_block_to_block (&se->post, &argse.post);
3694 len = argse.string_length;
3697 se->expr = convert (type, len);
3700 /* The length of a character string not including trailing blanks. */
3702 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
3704 int kind = expr->value.function.actual->expr->ts.kind;
3705 tree args[2], type, fndecl;
3707 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3708 type = gfc_typenode_for_spec (&expr->ts);
3711 fndecl = gfor_fndecl_string_len_trim;
3713 fndecl = gfor_fndecl_string_len_trim_char4;
3717 se->expr = build_call_expr_loc (input_location,
3718 fndecl, 2, args[0], args[1]);
3719 se->expr = convert (type, se->expr);
3723 /* Returns the starting position of a substring within a string. */
3726 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
3729 tree logical4_type_node = gfc_get_logical_type (4);
3733 unsigned int num_args;
3735 args = XALLOCAVEC (tree, 5);
3737 /* Get number of arguments; characters count double due to the
3738 string length argument. Kind= is not passed to the library
3739 and thus ignored. */
3740 if (expr->value.function.actual->next->next->expr == NULL)
3745 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3746 type = gfc_typenode_for_spec (&expr->ts);
3749 args[4] = build_int_cst (logical4_type_node, 0);
3751 args[4] = convert (logical4_type_node, args[4]);
3753 fndecl = build_addr (function, current_function_decl);
3754 se->expr = build_call_array_loc (input_location,
3755 TREE_TYPE (TREE_TYPE (function)), fndecl,
3757 se->expr = convert (type, se->expr);
3761 /* The ascii value for a single character. */
3763 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
3765 tree args[2], type, pchartype;
3767 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3768 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
3769 pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
3770 args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]);
3771 type = gfc_typenode_for_spec (&expr->ts);
3773 se->expr = build_fold_indirect_ref_loc (input_location,
3775 se->expr = convert (type, se->expr);
3779 /* Intrinsic ISNAN calls __builtin_isnan. */
3782 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
3786 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3787 se->expr = build_call_expr_loc (input_location,
3788 built_in_decls[BUILT_IN_ISNAN], 1, arg);
3789 STRIP_TYPE_NOPS (se->expr);
3790 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3794 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
3795 their argument against a constant integer value. */
3798 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
3802 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3803 se->expr = fold_build2 (EQ_EXPR, gfc_typenode_for_spec (&expr->ts),
3804 arg, build_int_cst (TREE_TYPE (arg), value));
3809 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
3812 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
3820 unsigned int num_args;
3822 num_args = gfc_intrinsic_argument_list_length (expr);
3823 args = XALLOCAVEC (tree, num_args);
3825 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3826 if (expr->ts.type != BT_CHARACTER)
3834 /* We do the same as in the non-character case, but the argument
3835 list is different because of the string length arguments. We
3836 also have to set the string length for the result. */
3843 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
3845 se->string_length = len;
3847 type = TREE_TYPE (tsource);
3848 se->expr = fold_build3 (COND_EXPR, type, mask, tsource,
3849 fold_convert (type, fsource));
3853 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
3855 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
3857 tree arg, type, tmp, frexp;
3859 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
3861 type = gfc_typenode_for_spec (&expr->ts);
3862 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3863 tmp = gfc_create_var (integer_type_node, NULL);
3864 se->expr = build_call_expr_loc (input_location, frexp, 2,
3865 fold_convert (type, arg),
3866 gfc_build_addr_expr (NULL_TREE, tmp));
3867 se->expr = fold_convert (type, se->expr);
3871 /* NEAREST (s, dir) is translated into
3872 tmp = copysign (HUGE_VAL, dir);
3873 return nextafter (s, tmp);
3876 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
3878 tree args[2], type, tmp, nextafter, copysign, huge_val;
3880 nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
3881 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
3882 huge_val = gfc_builtin_decl_for_float_kind (BUILT_IN_HUGE_VAL, expr->ts.kind);
3884 type = gfc_typenode_for_spec (&expr->ts);
3885 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3886 tmp = build_call_expr_loc (input_location, copysign, 2,
3887 build_call_expr_loc (input_location, huge_val, 0),
3888 fold_convert (type, args[1]));
3889 se->expr = build_call_expr_loc (input_location, nextafter, 2,
3890 fold_convert (type, args[0]), tmp);
3891 se->expr = fold_convert (type, se->expr);
3895 /* SPACING (s) is translated into
3903 e = MAX_EXPR (e, emin);
3904 res = scalbn (1., e);
3908 where prec is the precision of s, gfc_real_kinds[k].digits,
3909 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
3910 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
3913 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
3915 tree arg, type, prec, emin, tiny, res, e;
3916 tree cond, tmp, frexp, scalbn;
3920 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3921 prec = build_int_cst (NULL_TREE, gfc_real_kinds[k].digits);
3922 emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1);
3923 tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
3925 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
3926 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
3928 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3929 arg = gfc_evaluate_now (arg, &se->pre);
3931 type = gfc_typenode_for_spec (&expr->ts);
3932 e = gfc_create_var (integer_type_node, NULL);
3933 res = gfc_create_var (type, NULL);
3936 /* Build the block for s /= 0. */
3937 gfc_start_block (&block);
3938 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
3939 gfc_build_addr_expr (NULL_TREE, e));
3940 gfc_add_expr_to_block (&block, tmp);
3942 tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec);
3943 gfc_add_modify (&block, e, fold_build2 (MAX_EXPR, integer_type_node,
3946 tmp = build_call_expr_loc (input_location, scalbn, 2,
3947 build_real_from_int_cst (type, integer_one_node), e);
3948 gfc_add_modify (&block, res, tmp);
3950 /* Finish by building the IF statement. */
3951 cond = fold_build2 (EQ_EXPR, boolean_type_node, arg,
3952 build_real_from_int_cst (type, integer_zero_node));
3953 tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
3954 gfc_finish_block (&block));
3956 gfc_add_expr_to_block (&se->pre, tmp);
3961 /* RRSPACING (s) is translated into
3968 x = scalbn (x, precision - e);
3972 where precision is gfc_real_kinds[k].digits. */
3975 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
3977 tree arg, type, e, x, cond, stmt, tmp, frexp, scalbn, fabs;
3981 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3982 prec = gfc_real_kinds[k].digits;
3984 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
3985 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
3986 fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
3988 type = gfc_typenode_for_spec (&expr->ts);
3989 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3990 arg = gfc_evaluate_now (arg, &se->pre);
3992 e = gfc_create_var (integer_type_node, NULL);
3993 x = gfc_create_var (type, NULL);
3994 gfc_add_modify (&se->pre, x,
3995 build_call_expr_loc (input_location, fabs, 1, arg));
3998 gfc_start_block (&block);
3999 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
4000 gfc_build_addr_expr (NULL_TREE, e));
4001 gfc_add_expr_to_block (&block, tmp);
4003 tmp = fold_build2 (MINUS_EXPR, integer_type_node,
4004 build_int_cst (NULL_TREE, prec), e);
4005 tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
4006 gfc_add_modify (&block, x, tmp);
4007 stmt = gfc_finish_block (&block);
4009 cond = fold_build2 (NE_EXPR, boolean_type_node, x,
4010 build_real_from_int_cst (type, integer_zero_node));
4011 tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
4012 gfc_add_expr_to_block (&se->pre, tmp);
4014 se->expr = fold_convert (type, x);
4018 /* SCALE (s, i) is translated into scalbn (s, i). */
4020 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
4022 tree args[2], type, scalbn;
4024 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4026 type = gfc_typenode_for_spec (&expr->ts);
4027 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4028 se->expr = build_call_expr_loc (input_location, scalbn, 2,
4029 fold_convert (type, args[0]),
4030 fold_convert (integer_type_node, args[1]));
4031 se->expr = fold_convert (type, se->expr);
4035 /* SET_EXPONENT (s, i) is translated into
4036 scalbn (frexp (s, &dummy_int), i). */
4038 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
4040 tree args[2], type, tmp, frexp, scalbn;
4042 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4043 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4045 type = gfc_typenode_for_spec (&expr->ts);
4046 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4048 tmp = gfc_create_var (integer_type_node, NULL);
4049 tmp = build_call_expr_loc (input_location, frexp, 2,
4050 fold_convert (type, args[0]),
4051 gfc_build_addr_expr (NULL_TREE, tmp));
4052 se->expr = build_call_expr_loc (input_location, scalbn, 2, tmp,
4053 fold_convert (integer_type_node, args[1]));
4054 se->expr = fold_convert (type, se->expr);
4059 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
4061 gfc_actual_arglist *actual;
4069 gfc_init_se (&argse, NULL);
4070 actual = expr->value.function.actual;
4072 ss = gfc_walk_expr (actual->expr);
4073 gcc_assert (ss != gfc_ss_terminator);
4074 argse.want_pointer = 1;
4075 argse.data_not_needed = 1;
4076 gfc_conv_expr_descriptor (&argse, actual->expr, ss);
4077 gfc_add_block_to_block (&se->pre, &argse.pre);
4078 gfc_add_block_to_block (&se->post, &argse.post);
4079 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
4081 /* Build the call to size0. */
4082 fncall0 = build_call_expr_loc (input_location,
4083 gfor_fndecl_size0, 1, arg1);
4085 actual = actual->next;
4089 gfc_init_se (&argse, NULL);
4090 gfc_conv_expr_type (&argse, actual->expr,
4091 gfc_array_index_type);
4092 gfc_add_block_to_block (&se->pre, &argse.pre);
4094 /* Unusually, for an intrinsic, size does not exclude
4095 an optional arg2, so we must test for it. */
4096 if (actual->expr->expr_type == EXPR_VARIABLE
4097 && actual->expr->symtree->n.sym->attr.dummy
4098 && actual->expr->symtree->n.sym->attr.optional)
4101 /* Build the call to size1. */
4102 fncall1 = build_call_expr_loc (input_location,
4103 gfor_fndecl_size1, 2,
4106 gfc_init_se (&argse, NULL);
4107 argse.want_pointer = 1;
4108 argse.data_not_needed = 1;
4109 gfc_conv_expr (&argse, actual->expr);
4110 gfc_add_block_to_block (&se->pre, &argse.pre);
4111 tmp = fold_build2 (NE_EXPR, boolean_type_node,
4112 argse.expr, null_pointer_node);
4113 tmp = gfc_evaluate_now (tmp, &se->pre);
4114 se->expr = fold_build3 (COND_EXPR, pvoid_type_node,
4115 tmp, fncall1, fncall0);
4119 se->expr = NULL_TREE;
4120 argse.expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4121 argse.expr, gfc_index_one_node);
4124 else if (expr->value.function.actual->expr->rank == 1)
4126 argse.expr = gfc_index_zero_node;
4127 se->expr = NULL_TREE;
4132 if (se->expr == NULL_TREE)
4134 tree ubound, lbound;
4136 arg1 = build_fold_indirect_ref_loc (input_location,
4138 ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
4139 lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
4140 se->expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4142 se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, se->expr,
4143 gfc_index_one_node);
4144 se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
4145 gfc_index_zero_node);
4148 type = gfc_typenode_for_spec (&expr->ts);
4149 se->expr = convert (type, se->expr);
4153 /* Helper function to compute the size of a character variable,
4154 excluding the terminating null characters. The result has
4155 gfc_array_index_type type. */
4158 size_of_string_in_bytes (int kind, tree string_length)
4161 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
4163 bytesize = build_int_cst (gfc_array_index_type,
4164 gfc_character_kinds[i].bit_size / 8);
4166 return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize,
4167 fold_convert (gfc_array_index_type, string_length));
4172 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
4184 arg = expr->value.function.actual->expr;
4186 gfc_init_se (&argse, NULL);
4187 ss = gfc_walk_expr (arg);
4189 if (ss == gfc_ss_terminator)
4191 if (arg->ts.type == BT_CLASS)
4192 gfc_add_component_ref (arg, "$data");
4194 gfc_conv_expr_reference (&argse, arg);
4196 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4199 /* Obtain the source word length. */
4200 if (arg->ts.type == BT_CHARACTER)
4201 se->expr = size_of_string_in_bytes (arg->ts.kind,
4202 argse.string_length);
4204 se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
4208 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
4209 argse.want_pointer = 0;
4210 gfc_conv_expr_descriptor (&argse, arg, ss);
4211 type = gfc_get_element_type (TREE_TYPE (argse.expr));
4213 /* Obtain the argument's word length. */
4214 if (arg->ts.type == BT_CHARACTER)
4215 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
4217 tmp = fold_convert (gfc_array_index_type,
4218 size_in_bytes (type));
4219 gfc_add_modify (&argse.pre, source_bytes, tmp);
4221 /* Obtain the size of the array in bytes. */
4222 for (n = 0; n < arg->rank; n++)
4225 idx = gfc_rank_cst[n];
4226 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
4227 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
4228 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4230 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4231 tmp, gfc_index_one_node);
4232 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4234 gfc_add_modify (&argse.pre, source_bytes, tmp);
4236 se->expr = source_bytes;
4239 gfc_add_block_to_block (&se->pre, &argse.pre);
4244 gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
4249 tree type, result_type, tmp;
4251 arg = expr->value.function.actual->expr;
4252 gfc_init_se (&eight, NULL);
4253 gfc_conv_expr (&eight, gfc_get_int_expr (expr->ts.kind, NULL, 8));
4255 gfc_init_se (&argse, NULL);
4256 ss = gfc_walk_expr (arg);
4257 result_type = gfc_get_int_type (expr->ts.kind);
4259 if (ss == gfc_ss_terminator)
4261 if (arg->ts.type == BT_CLASS)
4263 gfc_add_component_ref (arg, "$vptr");
4264 gfc_add_component_ref (arg, "$size");
4265 gfc_conv_expr (&argse, arg);
4266 tmp = fold_convert (result_type, argse.expr);
4270 gfc_conv_expr_reference (&argse, arg);
4271 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4276 argse.want_pointer = 0;
4277 gfc_conv_expr_descriptor (&argse, arg, ss);
4278 type = gfc_get_element_type (TREE_TYPE (argse.expr));
4281 /* Obtain the argument's word length. */
4282 if (arg->ts.type == BT_CHARACTER)
4283 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
4285 tmp = fold_convert (result_type, size_in_bytes (type));
4288 se->expr = fold_build2 (MULT_EXPR, result_type, tmp, eight.expr);
4289 gfc_add_block_to_block (&se->pre, &argse.pre);
4293 /* Intrinsic string comparison functions. */
4296 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
4300 gfc_conv_intrinsic_function_args (se, expr, args, 4);
4303 = gfc_build_compare_string (args[0], args[1], args[2], args[3],
4304 expr->value.function.actual->expr->ts.kind,
4306 se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
4307 build_int_cst (TREE_TYPE (se->expr), 0));
4310 /* Generate a call to the adjustl/adjustr library function. */
4312 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
4320 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
4323 type = TREE_TYPE (args[2]);
4324 var = gfc_conv_string_tmp (se, type, len);
4327 tmp = build_call_expr_loc (input_location,
4328 fndecl, 3, args[0], args[1], args[2]);
4329 gfc_add_expr_to_block (&se->pre, tmp);
4331 se->string_length = len;
4335 /* Generate code for the TRANSFER intrinsic:
4337 DEST = TRANSFER (SOURCE, MOLD)
4339 typeof<DEST> = typeof<MOLD>
4344 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
4346 typeof<DEST> = typeof<MOLD>
4348 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
4349 sizeof (DEST(0) * SIZE). */
4351 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
4367 gfc_actual_arglist *arg;
4377 info = &se->ss->data.info;
4379 /* Convert SOURCE. The output from this stage is:-
4380 source_bytes = length of the source in bytes
4381 source = pointer to the source data. */
4382 arg = expr->value.function.actual;
4384 /* Ensure double transfer through LOGICAL preserves all
4386 if (arg->expr->expr_type == EXPR_FUNCTION
4387 && arg->expr->value.function.esym == NULL
4388 && arg->expr->value.function.isym != NULL
4389 && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
4390 && arg->expr->ts.type == BT_LOGICAL
4391 && expr->ts.type != arg->expr->ts.type)
4392 arg->expr->value.function.name = "__transfer_in_transfer";
4394 gfc_init_se (&argse, NULL);
4395 ss = gfc_walk_expr (arg->expr);
4397 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
4399 /* Obtain the pointer to source and the length of source in bytes. */
4400 if (ss == gfc_ss_terminator)
4402 gfc_conv_expr_reference (&argse, arg->expr);
4403 source = argse.expr;
4405 source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4408 /* Obtain the source word length. */
4409 if (arg->expr->ts.type == BT_CHARACTER)
4410 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
4411 argse.string_length);
4413 tmp = fold_convert (gfc_array_index_type,
4414 size_in_bytes (source_type));
4418 argse.want_pointer = 0;
4419 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
4420 source = gfc_conv_descriptor_data_get (argse.expr);
4421 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
4423 /* Repack the source if not a full variable array. */
4424 if (arg->expr->expr_type == EXPR_VARIABLE
4425 && arg->expr->ref->u.ar.type != AR_FULL)
4427 tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
4429 if (gfc_option.warn_array_temp)
4430 gfc_warning ("Creating array temporary at %L", &expr->where);
4432 source = build_call_expr_loc (input_location,
4433 gfor_fndecl_in_pack, 1, tmp);
4434 source = gfc_evaluate_now (source, &argse.pre);
4436 /* Free the temporary. */
4437 gfc_start_block (&block);
4438 tmp = gfc_call_free (convert (pvoid_type_node, source));
4439 gfc_add_expr_to_block (&block, tmp);
4440 stmt = gfc_finish_block (&block);
4442 /* Clean up if it was repacked. */
4443 gfc_init_block (&block);
4444 tmp = gfc_conv_array_data (argse.expr);
4445 tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp);
4446 tmp = build3_v (COND_EXPR, tmp, stmt,
4447 build_empty_stmt (input_location));
4448 gfc_add_expr_to_block (&block, tmp);
4449 gfc_add_block_to_block (&block, &se->post);
4450 gfc_init_block (&se->post);
4451 gfc_add_block_to_block (&se->post, &block);
4454 /* Obtain the source word length. */
4455 if (arg->expr->ts.type == BT_CHARACTER)
4456 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
4457 argse.string_length);
4459 tmp = fold_convert (gfc_array_index_type,
4460 size_in_bytes (source_type));
4462 /* Obtain the size of the array in bytes. */
4463 extent = gfc_create_var (gfc_array_index_type, NULL);
4464 for (n = 0; n < arg->expr->rank; n++)
4467 idx = gfc_rank_cst[n];
4468 gfc_add_modify (&argse.pre, source_bytes, tmp);
4469 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
4470 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
4471 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4473 gfc_add_modify (&argse.pre, extent, tmp);
4474 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4475 extent, gfc_index_one_node);
4476 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4481 gfc_add_modify (&argse.pre, source_bytes, tmp);
4482 gfc_add_block_to_block (&se->pre, &argse.pre);
4483 gfc_add_block_to_block (&se->post, &argse.post);
4485 /* Now convert MOLD. The outputs are:
4486 mold_type = the TREE type of MOLD
4487 dest_word_len = destination word length in bytes. */
4490 gfc_init_se (&argse, NULL);
4491 ss = gfc_walk_expr (arg->expr);
4493 scalar_mold = arg->expr->rank == 0;
4495 if (ss == gfc_ss_terminator)
4497 gfc_conv_expr_reference (&argse, arg->expr);
4498 mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4503 gfc_init_se (&argse, NULL);
4504 argse.want_pointer = 0;
4505 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
4506 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
4509 gfc_add_block_to_block (&se->pre, &argse.pre);
4510 gfc_add_block_to_block (&se->post, &argse.post);
4512 if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
4514 /* If this TRANSFER is nested in another TRANSFER, use a type
4515 that preserves all bits. */
4516 if (arg->expr->ts.type == BT_LOGICAL)
4517 mold_type = gfc_get_int_type (arg->expr->ts.kind);
4520 if (arg->expr->ts.type == BT_CHARACTER)
4522 tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
4523 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
4526 tmp = fold_convert (gfc_array_index_type,
4527 size_in_bytes (mold_type));
4529 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
4530 gfc_add_modify (&se->pre, dest_word_len, tmp);
4532 /* Finally convert SIZE, if it is present. */
4534 size_words = gfc_create_var (gfc_array_index_type, NULL);
4538 gfc_init_se (&argse, NULL);
4539 gfc_conv_expr_reference (&argse, arg->expr);
4540 tmp = convert (gfc_array_index_type,
4541 build_fold_indirect_ref_loc (input_location,
4543 gfc_add_block_to_block (&se->pre, &argse.pre);
4544 gfc_add_block_to_block (&se->post, &argse.post);
4549 /* Separate array and scalar results. */
4550 if (scalar_mold && tmp == NULL_TREE)
4551 goto scalar_transfer;
4553 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
4554 if (tmp != NULL_TREE)
4555 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4556 tmp, dest_word_len);
4560 gfc_add_modify (&se->pre, size_bytes, tmp);
4561 gfc_add_modify (&se->pre, size_words,
4562 fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
4563 size_bytes, dest_word_len));
4565 /* Evaluate the bounds of the result. If the loop range exists, we have
4566 to check if it is too large. If so, we modify loop->to be consistent
4567 with min(size, size(source)). Otherwise, size is made consistent with
4568 the loop range, so that the right number of bytes is transferred.*/
4569 n = se->loop->order[0];
4570 if (se->loop->to[n] != NULL_TREE)
4572 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4573 se->loop->to[n], se->loop->from[n]);
4574 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4575 tmp, gfc_index_one_node);
4576 tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
4578 gfc_add_modify (&se->pre, size_words, tmp);
4579 gfc_add_modify (&se->pre, size_bytes,
4580 fold_build2 (MULT_EXPR, gfc_array_index_type,
4581 size_words, dest_word_len));
4582 upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4583 size_words, se->loop->from[n]);
4584 upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4585 upper, gfc_index_one_node);
4589 upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4590 size_words, gfc_index_one_node);
4591 se->loop->from[n] = gfc_index_zero_node;
4594 se->loop->to[n] = upper;
4596 /* Build a destination descriptor, using the pointer, source, as the
4598 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
4599 info, mold_type, NULL_TREE, false, true, false,
4602 /* Cast the pointer to the result. */
4603 tmp = gfc_conv_descriptor_data_get (info->descriptor);
4604 tmp = fold_convert (pvoid_type_node, tmp);
4606 /* Use memcpy to do the transfer. */
4607 tmp = build_call_expr_loc (input_location,
4608 built_in_decls[BUILT_IN_MEMCPY],
4611 fold_convert (pvoid_type_node, source),
4612 fold_build2 (MIN_EXPR, gfc_array_index_type,
4613 size_bytes, source_bytes));
4614 gfc_add_expr_to_block (&se->pre, tmp);
4616 se->expr = info->descriptor;
4617 if (expr->ts.type == BT_CHARACTER)
4618 se->string_length = dest_word_len;
4622 /* Deal with scalar results. */
4624 extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
4625 dest_word_len, source_bytes);
4626 extent = fold_build2 (MAX_EXPR, gfc_array_index_type,
4627 extent, gfc_index_zero_node);
4629 if (expr->ts.type == BT_CHARACTER)
4634 ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
4635 tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
4638 /* If source is longer than the destination, use a pointer to
4639 the source directly. */
4640 gfc_init_block (&block);
4641 gfc_add_modify (&block, tmpdecl, ptr);
4642 direct = gfc_finish_block (&block);
4644 /* Otherwise, allocate a string with the length of the destination
4645 and copy the source into it. */
4646 gfc_init_block (&block);
4647 tmp = gfc_get_pchar_type (expr->ts.kind);
4648 tmp = gfc_call_malloc (&block, tmp, dest_word_len);
4649 gfc_add_modify (&block, tmpdecl,
4650 fold_convert (TREE_TYPE (ptr), tmp));
4651 tmp = build_call_expr_loc (input_location,
4652 built_in_decls[BUILT_IN_MEMCPY], 3,
4653 fold_convert (pvoid_type_node, tmpdecl),
4654 fold_convert (pvoid_type_node, ptr),
4656 gfc_add_expr_to_block (&block, tmp);
4657 indirect = gfc_finish_block (&block);
4659 /* Wrap it up with the condition. */
4660 tmp = fold_build2 (LE_EXPR, boolean_type_node,
4661 dest_word_len, source_bytes);
4662 tmp = build3_v (COND_EXPR, tmp, direct, indirect);
4663 gfc_add_expr_to_block (&se->pre, tmp);
4666 se->string_length = dest_word_len;
4670 tmpdecl = gfc_create_var (mold_type, "transfer");
4672 ptr = convert (build_pointer_type (mold_type), source);
4674 /* Use memcpy to do the transfer. */
4675 tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
4676 tmp = build_call_expr_loc (input_location,
4677 built_in_decls[BUILT_IN_MEMCPY], 3,
4678 fold_convert (pvoid_type_node, tmp),
4679 fold_convert (pvoid_type_node, ptr),
4681 gfc_add_expr_to_block (&se->pre, tmp);
4688 /* Generate code for the ALLOCATED intrinsic.
4689 Generate inline code that directly check the address of the argument. */
4692 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
4694 gfc_actual_arglist *arg1;
4699 gfc_init_se (&arg1se, NULL);
4700 arg1 = expr->value.function.actual;
4701 ss1 = gfc_walk_expr (arg1->expr);
4703 if (ss1 == gfc_ss_terminator)
4705 /* Allocatable scalar. */
4706 arg1se.want_pointer = 1;
4707 if (arg1->expr->ts.type == BT_CLASS)
4708 gfc_add_component_ref (arg1->expr, "$data");
4709 gfc_conv_expr (&arg1se, arg1->expr);
4714 /* Allocatable array. */
4715 arg1se.descriptor_only = 1;
4716 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4717 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
4720 tmp = fold_build2 (NE_EXPR, boolean_type_node,
4721 tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node));
4722 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
4726 /* Generate code for the ASSOCIATED intrinsic.
4727 If both POINTER and TARGET are arrays, generate a call to library function
4728 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
4729 In other cases, generate inline code that directly compare the address of
4730 POINTER with the address of TARGET. */
4733 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
4735 gfc_actual_arglist *arg1;
4736 gfc_actual_arglist *arg2;
4741 tree nonzero_charlen;
4742 tree nonzero_arraylen;
4745 gfc_init_se (&arg1se, NULL);
4746 gfc_init_se (&arg2se, NULL);
4747 arg1 = expr->value.function.actual;
4748 if (arg1->expr->ts.type == BT_CLASS)
4749 gfc_add_component_ref (arg1->expr, "$data");
4751 ss1 = gfc_walk_expr (arg1->expr);
4755 /* No optional target. */
4756 if (ss1 == gfc_ss_terminator)
4758 /* A pointer to a scalar. */
4759 arg1se.want_pointer = 1;
4760 gfc_conv_expr (&arg1se, arg1->expr);
4765 /* A pointer to an array. */
4766 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4767 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
4769 gfc_add_block_to_block (&se->pre, &arg1se.pre);
4770 gfc_add_block_to_block (&se->post, &arg1se.post);
4771 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp2,
4772 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
4777 /* An optional target. */
4778 if (arg2->expr->ts.type == BT_CLASS)
4779 gfc_add_component_ref (arg2->expr, "$data");
4780 ss2 = gfc_walk_expr (arg2->expr);
4782 nonzero_charlen = NULL_TREE;
4783 if (arg1->expr->ts.type == BT_CHARACTER)
4784 nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
4785 arg1->expr->ts.u.cl->backend_decl,
4788 if (ss1 == gfc_ss_terminator)
4790 /* A pointer to a scalar. */
4791 gcc_assert (ss2 == gfc_ss_terminator);
4792 arg1se.want_pointer = 1;
4793 gfc_conv_expr (&arg1se, arg1->expr);
4794 arg2se.want_pointer = 1;
4795 gfc_conv_expr (&arg2se, arg2->expr);
4796 gfc_add_block_to_block (&se->pre, &arg1se.pre);
4797 gfc_add_block_to_block (&se->post, &arg1se.post);
4798 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4799 arg1se.expr, arg2se.expr);
4800 tmp2 = fold_build2 (NE_EXPR, boolean_type_node,
4801 arg1se.expr, null_pointer_node);
4802 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4807 /* An array pointer of zero length is not associated if target is
4809 arg1se.descriptor_only = 1;
4810 gfc_conv_expr_lhs (&arg1se, arg1->expr);
4811 tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
4812 gfc_rank_cst[arg1->expr->rank - 1]);
4813 nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp,
4814 build_int_cst (TREE_TYPE (tmp), 0));
4816 /* A pointer to an array, call library function _gfor_associated. */
4817 gcc_assert (ss2 != gfc_ss_terminator);
4818 arg1se.want_pointer = 1;
4819 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4821 arg2se.want_pointer = 1;
4822 gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
4823 gfc_add_block_to_block (&se->pre, &arg2se.pre);
4824 gfc_add_block_to_block (&se->post, &arg2se.post);
4825 se->expr = build_call_expr_loc (input_location,
4826 gfor_fndecl_associated, 2,
4827 arg1se.expr, arg2se.expr);
4828 se->expr = convert (boolean_type_node, se->expr);
4829 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4830 se->expr, nonzero_arraylen);
4833 /* If target is present zero character length pointers cannot
4835 if (nonzero_charlen != NULL_TREE)
4836 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4837 se->expr, nonzero_charlen);
4840 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4844 /* Generate code for the SAME_TYPE_AS intrinsic.
4845 Generate inline code that directly checks the vindices. */
4848 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
4854 gfc_init_se (&se1, NULL);
4855 gfc_init_se (&se2, NULL);
4857 a = expr->value.function.actual->expr;
4858 b = expr->value.function.actual->next->expr;
4860 if (a->ts.type == BT_CLASS)
4862 gfc_add_component_ref (a, "$vptr");
4863 gfc_add_component_ref (a, "$hash");
4865 else if (a->ts.type == BT_DERIVED)
4866 a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4867 a->ts.u.derived->hash_value);
4869 if (b->ts.type == BT_CLASS)
4871 gfc_add_component_ref (b, "$vptr");
4872 gfc_add_component_ref (b, "$hash");
4874 else if (b->ts.type == BT_DERIVED)
4875 b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4876 b->ts.u.derived->hash_value);
4878 gfc_conv_expr (&se1, a);
4879 gfc_conv_expr (&se2, b);
4881 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4882 se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
4883 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
4887 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
4890 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
4894 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4895 se->expr = build_call_expr_loc (input_location,
4896 gfor_fndecl_sc_kind, 2, args[0], args[1]);
4897 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4901 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
4904 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
4908 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4910 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
4911 type = gfc_get_int_type (4);
4912 arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
4914 /* Convert it to the required type. */
4915 type = gfc_typenode_for_spec (&expr->ts);
4916 se->expr = build_call_expr_loc (input_location,
4917 gfor_fndecl_si_kind, 1, arg);
4918 se->expr = fold_convert (type, se->expr);
4922 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
4925 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
4927 gfc_actual_arglist *actual;
4930 VEC(tree,gc) *args = NULL;
4932 for (actual = expr->value.function.actual; actual; actual = actual->next)
4934 gfc_init_se (&argse, se);
4936 /* Pass a NULL pointer for an absent arg. */
4937 if (actual->expr == NULL)
4938 argse.expr = null_pointer_node;
4944 if (actual->expr->ts.kind != gfc_c_int_kind)
4946 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
4947 ts.type = BT_INTEGER;
4948 ts.kind = gfc_c_int_kind;
4949 gfc_convert_type (actual->expr, &ts, 2);
4951 gfc_conv_expr_reference (&argse, actual->expr);
4954 gfc_add_block_to_block (&se->pre, &argse.pre);
4955 gfc_add_block_to_block (&se->post, &argse.post);
4956 VEC_safe_push (tree, gc, args, argse.expr);
4959 /* Convert it to the required type. */
4960 type = gfc_typenode_for_spec (&expr->ts);
4961 se->expr = build_call_expr_loc_vec (input_location,
4962 gfor_fndecl_sr_kind, args);
4963 se->expr = fold_convert (type, se->expr);
4967 /* Generate code for TRIM (A) intrinsic function. */
4970 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
4980 unsigned int num_args;
4982 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
4983 args = XALLOCAVEC (tree, num_args);
4985 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
4986 addr = gfc_build_addr_expr (ppvoid_type_node, var);
4987 len = gfc_create_var (gfc_charlen_type_node, "len");
4989 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
4990 args[0] = gfc_build_addr_expr (NULL_TREE, len);
4993 if (expr->ts.kind == 1)
4994 function = gfor_fndecl_string_trim;
4995 else if (expr->ts.kind == 4)
4996 function = gfor_fndecl_string_trim_char4;
5000 fndecl = build_addr (function, current_function_decl);
5001 tmp = build_call_array_loc (input_location,
5002 TREE_TYPE (TREE_TYPE (function)), fndecl,
5004 gfc_add_expr_to_block (&se->pre, tmp);
5006 /* Free the temporary afterwards, if necessary. */
5007 cond = fold_build2 (GT_EXPR, boolean_type_node,
5008 len, build_int_cst (TREE_TYPE (len), 0));
5009 tmp = gfc_call_free (var);
5010 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
5011 gfc_add_expr_to_block (&se->post, tmp);
5014 se->string_length = len;
5018 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
5021 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
5023 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
5024 tree type, cond, tmp, count, exit_label, n, max, largest;
5026 stmtblock_t block, body;
5029 /* We store in charsize the size of a character. */
5030 i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
5031 size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
5033 /* Get the arguments. */
5034 gfc_conv_intrinsic_function_args (se, expr, args, 3);
5035 slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
5037 ncopies = gfc_evaluate_now (args[2], &se->pre);
5038 ncopies_type = TREE_TYPE (ncopies);
5040 /* Check that NCOPIES is not negative. */
5041 cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
5042 build_int_cst (ncopies_type, 0));
5043 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
5044 "Argument NCOPIES of REPEAT intrinsic is negative "
5045 "(its value is %lld)",
5046 fold_convert (long_integer_type_node, ncopies));
5048 /* If the source length is zero, any non negative value of NCOPIES
5049 is valid, and nothing happens. */
5050 n = gfc_create_var (ncopies_type, "ncopies");
5051 cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
5052 build_int_cst (size_type_node, 0));
5053 tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
5054 build_int_cst (ncopies_type, 0), ncopies);
5055 gfc_add_modify (&se->pre, n, tmp);
5058 /* Check that ncopies is not too large: ncopies should be less than
5059 (or equal to) MAX / slen, where MAX is the maximal integer of
5060 the gfc_charlen_type_node type. If slen == 0, we need a special
5061 case to avoid the division by zero. */
5062 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5063 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
5064 max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
5065 fold_convert (size_type_node, max), slen);
5066 largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
5067 ? size_type_node : ncopies_type;
5068 cond = fold_build2 (GT_EXPR, boolean_type_node,
5069 fold_convert (largest, ncopies),
5070 fold_convert (largest, max));
5071 tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
5072 build_int_cst (size_type_node, 0));
5073 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
5075 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
5076 "Argument NCOPIES of REPEAT intrinsic is too large");
5078 /* Compute the destination length. */
5079 dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
5080 fold_convert (gfc_charlen_type_node, slen),
5081 fold_convert (gfc_charlen_type_node, ncopies));
5082 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
5083 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
5085 /* Generate the code to do the repeat operation:
5086 for (i = 0; i < ncopies; i++)
5087 memmove (dest + (i * slen * size), src, slen*size); */
5088 gfc_start_block (&block);
5089 count = gfc_create_var (ncopies_type, "count");
5090 gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
5091 exit_label = gfc_build_label_decl (NULL_TREE);
5093 /* Start the loop body. */
5094 gfc_start_block (&body);
5096 /* Exit the loop if count >= ncopies. */
5097 cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
5098 tmp = build1_v (GOTO_EXPR, exit_label);
5099 TREE_USED (exit_label) = 1;
5100 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
5101 build_empty_stmt (input_location));
5102 gfc_add_expr_to_block (&body, tmp);
5104 /* Call memmove (dest + (i*slen*size), src, slen*size). */
5105 tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
5106 fold_convert (gfc_charlen_type_node, slen),
5107 fold_convert (gfc_charlen_type_node, count));
5108 tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
5109 tmp, fold_convert (gfc_charlen_type_node, size));
5110 tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
5111 fold_convert (pvoid_type_node, dest),
5112 fold_convert (sizetype, tmp));
5113 tmp = build_call_expr_loc (input_location,
5114 built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
5115 fold_build2 (MULT_EXPR, size_type_node, slen,
5116 fold_convert (size_type_node, size)));
5117 gfc_add_expr_to_block (&body, tmp);
5119 /* Increment count. */
5120 tmp = fold_build2 (PLUS_EXPR, ncopies_type,
5121 count, build_int_cst (TREE_TYPE (count), 1));
5122 gfc_add_modify (&body, count, tmp);
5124 /* Build the loop. */
5125 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
5126 gfc_add_expr_to_block (&block, tmp);
5128 /* Add the exit label. */
5129 tmp = build1_v (LABEL_EXPR, exit_label);
5130 gfc_add_expr_to_block (&block, tmp);
5132 /* Finish the block. */
5133 tmp = gfc_finish_block (&block);
5134 gfc_add_expr_to_block (&se->pre, tmp);
5136 /* Set the result value. */
5138 se->string_length = dlen;
5142 /* Generate code for the IARGC intrinsic. */
5145 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
5151 /* Call the library function. This always returns an INTEGER(4). */
5152 fndecl = gfor_fndecl_iargc;
5153 tmp = build_call_expr_loc (input_location,
5156 /* Convert it to the required type. */
5157 type = gfc_typenode_for_spec (&expr->ts);
5158 tmp = fold_convert (type, tmp);
5164 /* The loc intrinsic returns the address of its argument as
5165 gfc_index_integer_kind integer. */
5168 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
5174 gcc_assert (!se->ss);
5176 arg_expr = expr->value.function.actual->expr;
5177 ss = gfc_walk_expr (arg_expr);
5178 if (ss == gfc_ss_terminator)
5179 gfc_conv_expr_reference (se, arg_expr);
5181 gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL);
5182 se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
5184 /* Create a temporary variable for loc return value. Without this,
5185 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
5186 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
5187 gfc_add_modify (&se->pre, temp_var, se->expr);
5188 se->expr = temp_var;
5191 /* Generate code for an intrinsic function. Some map directly to library
5192 calls, others get special handling. In some cases the name of the function
5193 used depends on the type specifiers. */
5196 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
5202 name = &expr->value.function.name[2];
5204 if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
5206 lib = gfc_is_intrinsic_libcall (expr);
5210 se->ignore_optional = 1;
5212 switch (expr->value.function.isym->id)
5214 case GFC_ISYM_EOSHIFT:
5216 case GFC_ISYM_RESHAPE:
5217 /* For all of those the first argument specifies the type and the
5218 third is optional. */
5219 conv_generic_with_optional_char_arg (se, expr, 1, 3);
5223 gfc_conv_intrinsic_funcall (se, expr);
5231 switch (expr->value.function.isym->id)
5236 case GFC_ISYM_REPEAT:
5237 gfc_conv_intrinsic_repeat (se, expr);
5241 gfc_conv_intrinsic_trim (se, expr);
5244 case GFC_ISYM_SC_KIND:
5245 gfc_conv_intrinsic_sc_kind (se, expr);
5248 case GFC_ISYM_SI_KIND:
5249 gfc_conv_intrinsic_si_kind (se, expr);
5252 case GFC_ISYM_SR_KIND:
5253 gfc_conv_intrinsic_sr_kind (se, expr);
5256 case GFC_ISYM_EXPONENT:
5257 gfc_conv_intrinsic_exponent (se, expr);
5261 kind = expr->value.function.actual->expr->ts.kind;
5263 fndecl = gfor_fndecl_string_scan;
5265 fndecl = gfor_fndecl_string_scan_char4;
5269 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5272 case GFC_ISYM_VERIFY:
5273 kind = expr->value.function.actual->expr->ts.kind;
5275 fndecl = gfor_fndecl_string_verify;
5277 fndecl = gfor_fndecl_string_verify_char4;
5281 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5284 case GFC_ISYM_ALLOCATED:
5285 gfc_conv_allocated (se, expr);
5288 case GFC_ISYM_ASSOCIATED:
5289 gfc_conv_associated(se, expr);
5292 case GFC_ISYM_SAME_TYPE_AS:
5293 gfc_conv_same_type_as (se, expr);
5297 gfc_conv_intrinsic_abs (se, expr);
5300 case GFC_ISYM_ADJUSTL:
5301 if (expr->ts.kind == 1)
5302 fndecl = gfor_fndecl_adjustl;
5303 else if (expr->ts.kind == 4)
5304 fndecl = gfor_fndecl_adjustl_char4;
5308 gfc_conv_intrinsic_adjust (se, expr, fndecl);
5311 case GFC_ISYM_ADJUSTR:
5312 if (expr->ts.kind == 1)
5313 fndecl = gfor_fndecl_adjustr;
5314 else if (expr->ts.kind == 4)
5315 fndecl = gfor_fndecl_adjustr_char4;
5319 gfc_conv_intrinsic_adjust (se, expr, fndecl);
5322 case GFC_ISYM_AIMAG:
5323 gfc_conv_intrinsic_imagpart (se, expr);
5327 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
5331 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
5334 case GFC_ISYM_ANINT:
5335 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
5339 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
5343 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
5346 case GFC_ISYM_BTEST:
5347 gfc_conv_intrinsic_btest (se, expr);
5350 case GFC_ISYM_ACHAR:
5352 gfc_conv_intrinsic_char (se, expr);
5355 case GFC_ISYM_CONVERSION:
5357 case GFC_ISYM_LOGICAL:
5359 gfc_conv_intrinsic_conversion (se, expr);
5362 /* Integer conversions are handled separately to make sure we get the
5363 correct rounding mode. */
5368 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
5372 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
5375 case GFC_ISYM_CEILING:
5376 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
5379 case GFC_ISYM_FLOOR:
5380 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
5384 gfc_conv_intrinsic_mod (se, expr, 0);
5387 case GFC_ISYM_MODULO:
5388 gfc_conv_intrinsic_mod (se, expr, 1);
5391 case GFC_ISYM_CMPLX:
5392 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
5395 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
5396 gfc_conv_intrinsic_iargc (se, expr);
5399 case GFC_ISYM_COMPLEX:
5400 gfc_conv_intrinsic_cmplx (se, expr, 1);
5403 case GFC_ISYM_CONJG:
5404 gfc_conv_intrinsic_conjg (se, expr);
5407 case GFC_ISYM_COUNT:
5408 gfc_conv_intrinsic_count (se, expr);
5411 case GFC_ISYM_CTIME:
5412 gfc_conv_intrinsic_ctime (se, expr);
5416 gfc_conv_intrinsic_dim (se, expr);
5419 case GFC_ISYM_DOT_PRODUCT:
5420 gfc_conv_intrinsic_dot_product (se, expr);
5423 case GFC_ISYM_DPROD:
5424 gfc_conv_intrinsic_dprod (se, expr);
5427 case GFC_ISYM_FDATE:
5428 gfc_conv_intrinsic_fdate (se, expr);
5431 case GFC_ISYM_FRACTION:
5432 gfc_conv_intrinsic_fraction (se, expr);
5436 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
5439 case GFC_ISYM_IBCLR:
5440 gfc_conv_intrinsic_singlebitop (se, expr, 0);
5443 case GFC_ISYM_IBITS:
5444 gfc_conv_intrinsic_ibits (se, expr);
5447 case GFC_ISYM_IBSET:
5448 gfc_conv_intrinsic_singlebitop (se, expr, 1);
5451 case GFC_ISYM_IACHAR:
5452 case GFC_ISYM_ICHAR:
5453 /* We assume ASCII character sequence. */
5454 gfc_conv_intrinsic_ichar (se, expr);
5457 case GFC_ISYM_IARGC:
5458 gfc_conv_intrinsic_iargc (se, expr);
5462 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
5465 case GFC_ISYM_INDEX:
5466 kind = expr->value.function.actual->expr->ts.kind;
5468 fndecl = gfor_fndecl_string_index;
5470 fndecl = gfor_fndecl_string_index_char4;
5474 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5478 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
5481 case GFC_ISYM_IS_IOSTAT_END:
5482 gfc_conv_has_intvalue (se, expr, LIBERROR_END);
5485 case GFC_ISYM_IS_IOSTAT_EOR:
5486 gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
5489 case GFC_ISYM_ISNAN:
5490 gfc_conv_intrinsic_isnan (se, expr);
5493 case GFC_ISYM_LSHIFT:
5494 gfc_conv_intrinsic_rlshift (se, expr, 0);
5497 case GFC_ISYM_RSHIFT:
5498 gfc_conv_intrinsic_rlshift (se, expr, 1);
5501 case GFC_ISYM_ISHFT:
5502 gfc_conv_intrinsic_ishft (se, expr);
5505 case GFC_ISYM_ISHFTC:
5506 gfc_conv_intrinsic_ishftc (se, expr);
5509 case GFC_ISYM_LEADZ:
5510 gfc_conv_intrinsic_leadz (se, expr);
5513 case GFC_ISYM_TRAILZ:
5514 gfc_conv_intrinsic_trailz (se, expr);
5517 case GFC_ISYM_POPCNT:
5518 gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
5521 case GFC_ISYM_POPPAR:
5522 gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
5525 case GFC_ISYM_LBOUND:
5526 gfc_conv_intrinsic_bound (se, expr, 0);
5529 case GFC_ISYM_TRANSPOSE:
5530 if (se->ss && se->ss->useflags)
5532 gfc_conv_tmp_array_ref (se);
5533 gfc_advance_se_ss_chain (se);
5536 gfc_conv_array_transpose (se, expr->value.function.actual->expr);
5540 gfc_conv_intrinsic_len (se, expr);
5543 case GFC_ISYM_LEN_TRIM:
5544 gfc_conv_intrinsic_len_trim (se, expr);
5548 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
5552 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
5556 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
5560 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
5564 if (expr->ts.type == BT_CHARACTER)
5565 gfc_conv_intrinsic_minmax_char (se, expr, 1);
5567 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
5570 case GFC_ISYM_MAXLOC:
5571 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
5574 case GFC_ISYM_MAXVAL:
5575 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
5578 case GFC_ISYM_MERGE:
5579 gfc_conv_intrinsic_merge (se, expr);
5583 if (expr->ts.type == BT_CHARACTER)
5584 gfc_conv_intrinsic_minmax_char (se, expr, -1);
5586 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
5589 case GFC_ISYM_MINLOC:
5590 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
5593 case GFC_ISYM_MINVAL:
5594 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
5597 case GFC_ISYM_NEAREST:
5598 gfc_conv_intrinsic_nearest (se, expr);
5601 case GFC_ISYM_NORM2:
5602 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
5606 gfc_conv_intrinsic_not (se, expr);
5610 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
5613 case GFC_ISYM_PARITY:
5614 gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
5617 case GFC_ISYM_PRESENT:
5618 gfc_conv_intrinsic_present (se, expr);
5621 case GFC_ISYM_PRODUCT:
5622 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
5625 case GFC_ISYM_RRSPACING:
5626 gfc_conv_intrinsic_rrspacing (se, expr);
5629 case GFC_ISYM_SET_EXPONENT:
5630 gfc_conv_intrinsic_set_exponent (se, expr);
5633 case GFC_ISYM_SCALE:
5634 gfc_conv_intrinsic_scale (se, expr);
5638 gfc_conv_intrinsic_sign (se, expr);
5642 gfc_conv_intrinsic_size (se, expr);
5645 case GFC_ISYM_SIZEOF:
5646 case GFC_ISYM_C_SIZEOF:
5647 gfc_conv_intrinsic_sizeof (se, expr);
5650 case GFC_ISYM_STORAGE_SIZE:
5651 gfc_conv_intrinsic_storage_size (se, expr);
5654 case GFC_ISYM_SPACING:
5655 gfc_conv_intrinsic_spacing (se, expr);
5659 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
5662 case GFC_ISYM_TRANSFER:
5663 if (se->ss && se->ss->useflags)
5665 /* Access the previously obtained result. */
5666 gfc_conv_tmp_array_ref (se);
5667 gfc_advance_se_ss_chain (se);
5670 gfc_conv_intrinsic_transfer (se, expr);
5673 case GFC_ISYM_TTYNAM:
5674 gfc_conv_intrinsic_ttynam (se, expr);
5677 case GFC_ISYM_UBOUND:
5678 gfc_conv_intrinsic_bound (se, expr, 1);
5682 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
5686 gfc_conv_intrinsic_loc (se, expr);
5689 case GFC_ISYM_ACCESS:
5690 case GFC_ISYM_CHDIR:
5691 case GFC_ISYM_CHMOD:
5692 case GFC_ISYM_DTIME:
5693 case GFC_ISYM_ETIME:
5694 case GFC_ISYM_EXTENDS_TYPE_OF:
5696 case GFC_ISYM_FGETC:
5699 case GFC_ISYM_FPUTC:
5700 case GFC_ISYM_FSTAT:
5701 case GFC_ISYM_FTELL:
5702 case GFC_ISYM_GETCWD:
5703 case GFC_ISYM_GETGID:
5704 case GFC_ISYM_GETPID:
5705 case GFC_ISYM_GETUID:
5706 case GFC_ISYM_HOSTNM:
5708 case GFC_ISYM_IERRNO:
5709 case GFC_ISYM_IRAND:
5710 case GFC_ISYM_ISATTY:
5713 case GFC_ISYM_LSTAT:
5714 case GFC_ISYM_MALLOC:
5715 case GFC_ISYM_MATMUL:
5716 case GFC_ISYM_MCLOCK:
5717 case GFC_ISYM_MCLOCK8:
5719 case GFC_ISYM_RENAME:
5720 case GFC_ISYM_SECOND:
5721 case GFC_ISYM_SECNDS:
5722 case GFC_ISYM_SIGNAL:
5724 case GFC_ISYM_SYMLNK:
5725 case GFC_ISYM_SYSTEM:
5727 case GFC_ISYM_TIME8:
5728 case GFC_ISYM_UMASK:
5729 case GFC_ISYM_UNLINK:
5731 gfc_conv_intrinsic_funcall (se, expr);
5734 case GFC_ISYM_EOSHIFT:
5736 case GFC_ISYM_RESHAPE:
5737 /* For those, expr->rank should always be >0 and thus the if above the
5738 switch should have matched. */
5743 gfc_conv_intrinsic_lib_function (se, expr);
5749 /* This generates code to execute before entering the scalarization loop.
5750 Currently does nothing. */
5753 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
5755 switch (ss->expr->value.function.isym->id)
5757 case GFC_ISYM_UBOUND:
5758 case GFC_ISYM_LBOUND:
5767 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
5768 inside the scalarization loop. */
5771 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
5775 /* The two argument version returns a scalar. */
5776 if (expr->value.function.actual->next->expr)
5779 newss = gfc_get_ss ();
5780 newss->type = GFC_SS_INTRINSIC;
5783 newss->data.info.dimen = 1;
5789 /* Walk an intrinsic array libcall. */
5792 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
5796 gcc_assert (expr->rank > 0);
5798 newss = gfc_get_ss ();
5799 newss->type = GFC_SS_FUNCTION;
5802 newss->data.info.dimen = expr->rank;
5808 /* Returns nonzero if the specified intrinsic function call maps directly to
5809 an external library call. Should only be used for functions that return
5813 gfc_is_intrinsic_libcall (gfc_expr * expr)
5815 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
5816 gcc_assert (expr->rank > 0);
5818 switch (expr->value.function.isym->id)
5822 case GFC_ISYM_COUNT:
5824 case GFC_ISYM_MATMUL:
5825 case GFC_ISYM_MAXLOC:
5826 case GFC_ISYM_MAXVAL:
5827 case GFC_ISYM_MINLOC:
5828 case GFC_ISYM_MINVAL:
5829 case GFC_ISYM_NORM2:
5830 case GFC_ISYM_PARITY:
5831 case GFC_ISYM_PRODUCT:
5833 case GFC_ISYM_SHAPE:
5834 case GFC_ISYM_SPREAD:
5835 case GFC_ISYM_TRANSPOSE:
5837 /* Ignore absent optional parameters. */
5840 case GFC_ISYM_RESHAPE:
5841 case GFC_ISYM_CSHIFT:
5842 case GFC_ISYM_EOSHIFT:
5844 case GFC_ISYM_UNPACK:
5845 /* Pass absent optional parameters. */
5853 /* Walk an intrinsic function. */
5855 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
5856 gfc_intrinsic_sym * isym)
5860 if (isym->elemental)
5861 return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
5863 if (expr->rank == 0)
5866 if (gfc_is_intrinsic_libcall (expr))
5867 return gfc_walk_intrinsic_libfunc (ss, expr);
5869 /* Special cases. */
5872 case GFC_ISYM_LBOUND:
5873 case GFC_ISYM_UBOUND:
5874 return gfc_walk_intrinsic_bound (ss, expr);
5876 case GFC_ISYM_TRANSFER:
5877 return gfc_walk_intrinsic_libfunc (ss, expr);
5880 /* This probably meant someone forgot to add an intrinsic to the above
5881 list(s) when they implemented it, or something's gone horribly
5889 gfc_conv_intrinsic_move_alloc (gfc_code *code)
5891 if (code->ext.actual->expr->rank == 0)
5893 /* Scalar arguments: Generate pointer assignments. */
5894 gfc_expr *from, *to;
5898 from = code->ext.actual->expr;
5899 to = code->ext.actual->next->expr;
5901 gfc_start_block (&block);
5903 if (to->ts.type == BT_CLASS)
5904 tmp = gfc_trans_class_assign (to, from, EXEC_POINTER_ASSIGN);
5906 tmp = gfc_trans_pointer_assignment (to, from);
5907 gfc_add_expr_to_block (&block, tmp);
5909 if (from->ts.type == BT_CLASS)
5910 tmp = gfc_trans_class_assign (from, gfc_get_null_expr (NULL),
5911 EXEC_POINTER_ASSIGN);
5913 tmp = gfc_trans_pointer_assignment (from,
5914 gfc_get_null_expr (NULL));
5915 gfc_add_expr_to_block (&block, tmp);
5917 return gfc_finish_block (&block);
5920 /* Array arguments: Generate library code. */
5921 return gfc_trans_call (code, false, NULL_TREE, NULL_TREE, false);
5925 #include "gt-fortran-trans-intrinsic.h"