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_loc (input_location, REALPART_EXPR, artype,
338 se->expr = convert (type, args[0]);
341 /* This is needed because the gcc backend only implements
342 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
343 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
344 Similarly for CEILING. */
347 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
354 argtype = TREE_TYPE (arg);
355 arg = gfc_evaluate_now (arg, pblock);
357 intval = convert (type, arg);
358 intval = gfc_evaluate_now (intval, pblock);
360 tmp = convert (argtype, intval);
361 cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
362 boolean_type_node, tmp, arg);
364 tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
365 intval, build_int_cst (type, 1));
366 tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
371 /* Round to nearest integer, away from zero. */
374 build_round_expr (tree arg, tree restype)
379 int argprec, resprec;
381 argtype = TREE_TYPE (arg);
382 argprec = TYPE_PRECISION (argtype);
383 resprec = TYPE_PRECISION (restype);
385 /* Depending on the type of the result, choose the long int intrinsic
386 (lround family) or long long intrinsic (llround). We might also
387 need to convert the result afterwards. */
388 if (resprec <= LONG_TYPE_SIZE)
390 else if (resprec <= LONG_LONG_TYPE_SIZE)
395 /* Now, depending on the argument type, we choose between intrinsics. */
397 fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
399 fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
401 return fold_convert (restype, build_call_expr_loc (input_location,
406 /* Convert a real to an integer using a specific rounding mode.
407 Ideally we would just build the corresponding GENERIC node,
408 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
411 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
412 enum rounding_mode op)
417 return build_fixbound_expr (pblock, arg, type, 0);
421 return build_fixbound_expr (pblock, arg, type, 1);
425 return build_round_expr (arg, type);
429 return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
438 /* Round a real value using the specified rounding mode.
439 We use a temporary integer of that same kind size as the result.
440 Values larger than those that can be represented by this kind are
441 unchanged, as they will not be accurate enough to represent the
443 huge = HUGE (KIND (a))
444 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
448 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
460 kind = expr->ts.kind;
461 nargs = gfc_intrinsic_argument_list_length (expr);
464 /* We have builtin functions for some cases. */
468 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
472 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
479 /* Evaluate the argument. */
480 gcc_assert (expr->value.function.actual->expr);
481 gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
483 /* Use a builtin function if one exists. */
484 if (decl != NULL_TREE)
486 se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
490 /* This code is probably redundant, but we'll keep it lying around just
492 type = gfc_typenode_for_spec (&expr->ts);
493 arg[0] = gfc_evaluate_now (arg[0], &se->pre);
495 /* Test if the value is too large to handle sensibly. */
496 gfc_set_model_kind (kind);
498 n = gfc_validate_kind (BT_INTEGER, kind, false);
499 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
500 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
501 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, arg[0],
504 mpfr_neg (huge, huge, GFC_RND_MODE);
505 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
506 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, arg[0],
508 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
510 itype = gfc_get_int_type (kind);
512 tmp = build_fix_expr (&se->pre, arg[0], itype, op);
513 tmp = convert (type, tmp);
514 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
520 /* Convert to an integer using the specified rounding mode. */
523 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
529 nargs = gfc_intrinsic_argument_list_length (expr);
530 args = XALLOCAVEC (tree, nargs);
532 /* Evaluate the argument, we process all arguments even though we only
533 use the first one for code generation purposes. */
534 type = gfc_typenode_for_spec (&expr->ts);
535 gcc_assert (expr->value.function.actual->expr);
536 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
538 if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
540 /* Conversion to a different integer kind. */
541 se->expr = convert (type, args[0]);
545 /* Conversion from complex to non-complex involves taking the real
546 component of the value. */
547 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
548 && expr->ts.type != BT_COMPLEX)
552 artype = TREE_TYPE (TREE_TYPE (args[0]));
553 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
557 se->expr = build_fix_expr (&se->pre, args[0], type, op);
562 /* Get the imaginary component of a value. */
565 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
569 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
570 se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
571 TREE_TYPE (TREE_TYPE (arg)), arg);
575 /* Get the complex conjugate of a value. */
578 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
582 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
583 se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
589 define_quad_builtin (const char *name, tree type, bool is_const)
592 fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
595 /* Mark the decl as external. */
596 DECL_EXTERNAL (fndecl) = 1;
597 TREE_PUBLIC (fndecl) = 1;
599 /* Mark it __attribute__((const)). */
600 TREE_READONLY (fndecl) = is_const;
602 rest_of_decl_compilation (fndecl, 1, 0);
609 /* Initialize function decls for library functions. The external functions
610 are created as required. Builtin functions are added here. */
613 gfc_build_intrinsic_lib_fndecls (void)
615 gfc_intrinsic_map_t *m;
616 tree quad_decls[END_BUILTINS + 1];
618 if (gfc_real16_is_float128)
620 /* If we have soft-float types, we create the decls for their
621 C99-like library functions. For now, we only handle __float128
622 q-suffixed functions. */
624 tree tmp, func_0, func_1, func_2, func_cabs, func_frexp;
625 tree func_lround, func_llround, func_scalbn, func_cpow;
627 memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
629 /* type (*) (void) */
630 func_0 = build_function_type (float128_type_node, void_list_node);
631 /* type (*) (type) */
632 tmp = tree_cons (NULL_TREE, float128_type_node, void_list_node);
633 func_1 = build_function_type (float128_type_node, tmp);
634 /* long (*) (type) */
635 func_lround = build_function_type (long_integer_type_node, tmp);
636 /* long long (*) (type) */
637 func_llround = build_function_type (long_long_integer_type_node, tmp);
638 /* type (*) (type, type) */
639 tmp = tree_cons (NULL_TREE, float128_type_node, tmp);
640 func_2 = build_function_type (float128_type_node, tmp);
641 /* type (*) (type, &int) */
642 tmp = tree_cons (NULL_TREE, float128_type_node, void_list_node);
643 tmp = tree_cons (NULL_TREE, build_pointer_type (integer_type_node), tmp);
644 func_frexp = build_function_type (float128_type_node, tmp);
645 /* type (*) (type, int) */
646 tmp = tree_cons (NULL_TREE, float128_type_node, void_list_node);
647 tmp = tree_cons (NULL_TREE, integer_type_node, tmp);
648 func_scalbn = build_function_type (float128_type_node, tmp);
649 /* type (*) (complex type) */
650 tmp = tree_cons (NULL_TREE, complex_float128_type_node, void_list_node);
651 func_cabs = build_function_type (float128_type_node, tmp);
652 /* complex type (*) (complex type, complex type) */
653 tmp = tree_cons (NULL_TREE, complex_float128_type_node, tmp);
654 func_cpow = build_function_type (complex_float128_type_node, tmp);
656 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
657 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
658 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
660 /* Only these built-ins are actually needed here. These are used directly
661 from the code, when calling builtin_decl_for_precision() or
662 builtin_decl_for_float_type(). The others are all constructed by
663 gfc_get_intrinsic_lib_fndecl(). */
664 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
665 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
667 #include "mathbuiltins.def"
671 #undef DEFINE_MATH_BUILTIN
672 #undef DEFINE_MATH_BUILTIN_C
676 /* Add GCC builtin functions. */
677 for (m = gfc_intrinsic_map;
678 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
680 if (m->float_built_in != END_BUILTINS)
681 m->real4_decl = built_in_decls[m->float_built_in];
682 if (m->complex_float_built_in != END_BUILTINS)
683 m->complex4_decl = built_in_decls[m->complex_float_built_in];
684 if (m->double_built_in != END_BUILTINS)
685 m->real8_decl = built_in_decls[m->double_built_in];
686 if (m->complex_double_built_in != END_BUILTINS)
687 m->complex8_decl = built_in_decls[m->complex_double_built_in];
689 /* If real(kind=10) exists, it is always long double. */
690 if (m->long_double_built_in != END_BUILTINS)
691 m->real10_decl = built_in_decls[m->long_double_built_in];
692 if (m->complex_long_double_built_in != END_BUILTINS)
693 m->complex10_decl = built_in_decls[m->complex_long_double_built_in];
695 if (!gfc_real16_is_float128)
697 if (m->long_double_built_in != END_BUILTINS)
698 m->real16_decl = built_in_decls[m->long_double_built_in];
699 if (m->complex_long_double_built_in != END_BUILTINS)
700 m->complex16_decl = built_in_decls[m->complex_long_double_built_in];
702 else if (quad_decls[m->double_built_in] != NULL_TREE)
704 /* Quad-precision function calls are constructed when first
705 needed by builtin_decl_for_precision(), except for those
706 that will be used directly (define by OTHER_BUILTIN). */
707 m->real16_decl = quad_decls[m->double_built_in];
709 else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
711 /* Same thing for the complex ones. */
712 m->complex16_decl = quad_decls[m->double_built_in];
718 /* Create a fndecl for a simple intrinsic library function. */
721 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
726 gfc_actual_arglist *actual;
729 char name[GFC_MAX_SYMBOL_LEN + 3];
732 if (ts->type == BT_REAL)
737 pdecl = &m->real4_decl;
740 pdecl = &m->real8_decl;
743 pdecl = &m->real10_decl;
746 pdecl = &m->real16_decl;
752 else if (ts->type == BT_COMPLEX)
754 gcc_assert (m->complex_available);
759 pdecl = &m->complex4_decl;
762 pdecl = &m->complex8_decl;
765 pdecl = &m->complex10_decl;
768 pdecl = &m->complex16_decl;
782 int n = gfc_validate_kind (BT_REAL, ts->kind, false);
783 if (gfc_real_kinds[n].c_float)
784 snprintf (name, sizeof (name), "%s%s%s",
785 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
786 else if (gfc_real_kinds[n].c_double)
787 snprintf (name, sizeof (name), "%s%s",
788 ts->type == BT_COMPLEX ? "c" : "", m->name);
789 else if (gfc_real_kinds[n].c_long_double)
790 snprintf (name, sizeof (name), "%s%s%s",
791 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
792 else if (gfc_real_kinds[n].c_float128)
793 snprintf (name, sizeof (name), "%s%s%s",
794 ts->type == BT_COMPLEX ? "c" : "", m->name, "q");
800 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
801 ts->type == BT_COMPLEX ? 'c' : 'r',
805 argtypes = NULL_TREE;
806 for (actual = expr->value.function.actual; actual; actual = actual->next)
808 type = gfc_typenode_for_spec (&actual->expr->ts);
809 argtypes = gfc_chainon_list (argtypes, type);
811 argtypes = chainon (argtypes, void_list_node);
812 type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
813 fndecl = build_decl (input_location,
814 FUNCTION_DECL, get_identifier (name), type);
816 /* Mark the decl as external. */
817 DECL_EXTERNAL (fndecl) = 1;
818 TREE_PUBLIC (fndecl) = 1;
820 /* Mark it __attribute__((const)), if possible. */
821 TREE_READONLY (fndecl) = m->is_constant;
823 rest_of_decl_compilation (fndecl, 1, 0);
830 /* Convert an intrinsic function into an external or builtin call. */
833 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
835 gfc_intrinsic_map_t *m;
839 unsigned int num_args;
842 id = expr->value.function.isym->id;
843 /* Find the entry for this function. */
844 for (m = gfc_intrinsic_map;
845 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
851 if (m->id == GFC_ISYM_NONE)
853 internal_error ("Intrinsic function %s(%d) not recognized",
854 expr->value.function.name, id);
857 /* Get the decl and generate the call. */
858 num_args = gfc_intrinsic_argument_list_length (expr);
859 args = XALLOCAVEC (tree, num_args);
861 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
862 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
863 rettype = TREE_TYPE (TREE_TYPE (fndecl));
865 fndecl = build_addr (fndecl, current_function_decl);
866 se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
870 /* If bounds-checking is enabled, create code to verify at runtime that the
871 string lengths for both expressions are the same (needed for e.g. MERGE).
872 If bounds-checking is not enabled, does nothing. */
875 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
876 tree a, tree b, stmtblock_t* target)
881 /* If bounds-checking is disabled, do nothing. */
882 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
885 /* Compare the two string lengths. */
886 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, a, b);
888 /* Output the runtime-check. */
889 name = gfc_build_cstring_const (intr_name);
890 name = gfc_build_addr_expr (pchar_type_node, name);
891 gfc_trans_runtime_check (true, false, cond, target, where,
892 "Unequal character lengths (%ld/%ld) in %s",
893 fold_convert (long_integer_type_node, a),
894 fold_convert (long_integer_type_node, b), name);
898 /* The EXPONENT(s) intrinsic function is translated into
905 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
907 tree arg, type, res, tmp, frexp;
909 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
910 expr->value.function.actual->expr->ts.kind);
912 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
914 res = gfc_create_var (integer_type_node, NULL);
915 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
916 gfc_build_addr_expr (NULL_TREE, res));
917 gfc_add_expr_to_block (&se->pre, tmp);
919 type = gfc_typenode_for_spec (&expr->ts);
920 se->expr = fold_convert (type, res);
923 /* Evaluate a single upper or lower bound. */
924 /* TODO: bound intrinsic generates way too much unnecessary code. */
927 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
929 gfc_actual_arglist *arg;
930 gfc_actual_arglist *arg2;
935 tree cond, cond1, cond3, cond4, size;
942 arg = expr->value.function.actual;
947 /* Create an implicit second parameter from the loop variable. */
948 gcc_assert (!arg2->expr);
949 gcc_assert (se->loop->dimen == 1);
950 gcc_assert (se->ss->expr == expr);
951 gfc_advance_se_ss_chain (se);
952 bound = se->loop->loopvar[0];
953 bound = fold_build2_loc (input_location, MINUS_EXPR,
954 gfc_array_index_type, bound,
959 /* use the passed argument. */
960 gcc_assert (arg->next->expr);
961 gfc_init_se (&argse, NULL);
962 gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
963 gfc_add_block_to_block (&se->pre, &argse.pre);
965 /* Convert from one based to zero based. */
966 bound = fold_build2_loc (input_location, MINUS_EXPR,
967 gfc_array_index_type, bound,
971 /* TODO: don't re-evaluate the descriptor on each iteration. */
972 /* Get a descriptor for the first parameter. */
973 ss = gfc_walk_expr (arg->expr);
974 gcc_assert (ss != gfc_ss_terminator);
975 gfc_init_se (&argse, NULL);
976 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
977 gfc_add_block_to_block (&se->pre, &argse.pre);
978 gfc_add_block_to_block (&se->post, &argse.post);
982 if (INTEGER_CST_P (bound))
986 hi = TREE_INT_CST_HIGH (bound);
987 low = TREE_INT_CST_LOW (bound);
988 if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
989 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
990 "dimension index", upper ? "UBOUND" : "LBOUND",
995 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
997 bound = gfc_evaluate_now (bound, &se->pre);
998 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
999 bound, build_int_cst (TREE_TYPE (bound), 0));
1000 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
1001 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1003 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1004 boolean_type_node, cond, tmp);
1005 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1010 ubound = gfc_conv_descriptor_ubound_get (desc, bound);
1011 lbound = gfc_conv_descriptor_lbound_get (desc, bound);
1013 as = gfc_get_full_arrayspec_from_expr (arg->expr);
1015 /* 13.14.53: Result value for LBOUND
1017 Case (i): For an array section or for an array expression other than a
1018 whole array or array structure component, LBOUND(ARRAY, DIM)
1019 has the value 1. For a whole array or array structure
1020 component, LBOUND(ARRAY, DIM) has the value:
1021 (a) equal to the lower bound for subscript DIM of ARRAY if
1022 dimension DIM of ARRAY does not have extent zero
1023 or if ARRAY is an assumed-size array of rank DIM,
1026 13.14.113: Result value for UBOUND
1028 Case (i): For an array section or for an array expression other than a
1029 whole array or array structure component, UBOUND(ARRAY, DIM)
1030 has the value equal to the number of elements in the given
1031 dimension; otherwise, it has a value equal to the upper bound
1032 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1033 not have size zero and has value zero if dimension DIM has
1038 tree stride = gfc_conv_descriptor_stride_get (desc, bound);
1040 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1042 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1043 stride, gfc_index_zero_node);
1044 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1045 boolean_type_node, cond3, cond1);
1046 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1047 stride, gfc_index_zero_node);
1052 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1053 boolean_type_node, cond3, cond4);
1054 cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1055 gfc_index_one_node, lbound);
1056 cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1057 boolean_type_node, cond4, cond5);
1059 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1060 boolean_type_node, cond, cond5);
1062 se->expr = fold_build3_loc (input_location, COND_EXPR,
1063 gfc_array_index_type, cond,
1064 ubound, gfc_index_zero_node);
1068 if (as->type == AS_ASSUMED_SIZE)
1069 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1070 bound, build_int_cst (TREE_TYPE (bound),
1071 arg->expr->rank - 1));
1073 cond = boolean_false_node;
1075 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1076 boolean_type_node, cond3, cond4);
1077 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1078 boolean_type_node, cond, cond1);
1080 se->expr = fold_build3_loc (input_location, COND_EXPR,
1081 gfc_array_index_type, cond,
1082 lbound, gfc_index_one_node);
1089 size = fold_build2_loc (input_location, MINUS_EXPR,
1090 gfc_array_index_type, ubound, lbound);
1091 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
1092 gfc_array_index_type, size,
1093 gfc_index_one_node);
1094 se->expr = fold_build2_loc (input_location, MAX_EXPR,
1095 gfc_array_index_type, se->expr,
1096 gfc_index_zero_node);
1099 se->expr = gfc_index_one_node;
1102 type = gfc_typenode_for_spec (&expr->ts);
1103 se->expr = convert (type, se->expr);
1108 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
1112 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1114 switch (expr->value.function.actual->expr->ts.type)
1118 se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
1123 cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
1124 se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
1133 /* Create a complex value from one or two real components. */
1136 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1142 unsigned int num_args;
1144 num_args = gfc_intrinsic_argument_list_length (expr);
1145 args = XALLOCAVEC (tree, num_args);
1147 type = gfc_typenode_for_spec (&expr->ts);
1148 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1149 real = convert (TREE_TYPE (type), args[0]);
1151 imag = convert (TREE_TYPE (type), args[1]);
1152 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1154 imag = fold_build1_loc (input_location, IMAGPART_EXPR,
1155 TREE_TYPE (TREE_TYPE (args[0])), args[0]);
1156 imag = convert (TREE_TYPE (type), imag);
1159 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1161 se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
1164 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1165 MODULO(A, P) = A - FLOOR (A / P) * P */
1166 /* TODO: MOD(x, 0) */
1169 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1181 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1183 switch (expr->ts.type)
1186 /* Integer case is easy, we've got a builtin op. */
1187 type = TREE_TYPE (args[0]);
1190 se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
1193 se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
1199 /* Check if we have a builtin fmod. */
1200 fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
1202 /* Use it if it exists. */
1203 if (fmod != NULL_TREE)
1205 tmp = build_addr (fmod, current_function_decl);
1206 se->expr = build_call_array_loc (input_location,
1207 TREE_TYPE (TREE_TYPE (fmod)),
1213 type = TREE_TYPE (args[0]);
1215 args[0] = gfc_evaluate_now (args[0], &se->pre);
1216 args[1] = gfc_evaluate_now (args[1], &se->pre);
1219 modulo = arg - floor (arg/arg2) * arg2, so
1220 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1222 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1223 thereby avoiding another division and retaining the accuracy
1224 of the builtin function. */
1225 if (fmod != NULL_TREE && modulo)
1227 tree zero = gfc_build_const (type, integer_zero_node);
1228 tmp = gfc_evaluate_now (se->expr, &se->pre);
1229 test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1231 test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1233 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
1234 boolean_type_node, test, test2);
1235 test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1237 test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1238 boolean_type_node, test, test2);
1239 test = gfc_evaluate_now (test, &se->pre);
1240 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
1241 fold_build2_loc (input_location, PLUS_EXPR,
1242 type, tmp, args[1]), tmp);
1246 /* If we do not have a built_in fmod, the calculation is going to
1247 have to be done longhand. */
1248 tmp = fold_build2_loc (input_location, RDIV_EXPR, type, args[0], args[1]);
1250 /* Test if the value is too large to handle sensibly. */
1251 gfc_set_model_kind (expr->ts.kind);
1253 n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1254 ikind = expr->ts.kind;
1257 n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1258 ikind = gfc_max_integer_kind;
1260 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1261 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1262 test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1265 mpfr_neg (huge, huge, GFC_RND_MODE);
1266 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1267 test = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
1269 test2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1270 boolean_type_node, test, test2);
1272 itype = gfc_get_int_type (ikind);
1274 tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1276 tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1277 tmp = convert (type, tmp);
1278 tmp = fold_build3_loc (input_location, COND_EXPR, type, test2, tmp,
1280 tmp = fold_build2_loc (input_location, MULT_EXPR, type, tmp, args[1]);
1281 se->expr = fold_build2_loc (input_location, MINUS_EXPR, type, args[0],
1291 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1294 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1302 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1303 type = TREE_TYPE (args[0]);
1305 val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
1306 val = gfc_evaluate_now (val, &se->pre);
1308 zero = gfc_build_const (type, integer_zero_node);
1309 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, val, zero);
1310 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
1314 /* SIGN(A, B) is absolute value of A times sign of B.
1315 The real value versions use library functions to ensure the correct
1316 handling of negative zero. Integer case implemented as:
1317 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1321 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1327 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1328 if (expr->ts.type == BT_REAL)
1332 tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
1333 abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
1335 /* We explicitly have to ignore the minus sign. We do so by using
1336 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1337 if (!gfc_option.flag_sign_zero
1338 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
1341 zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
1342 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1344 se->expr = fold_build3_loc (input_location, COND_EXPR,
1345 TREE_TYPE (args[0]), cond,
1346 build_call_expr_loc (input_location, abs, 1,
1348 build_call_expr_loc (input_location, tmp, 2,
1352 se->expr = build_call_expr_loc (input_location, tmp, 2,
1357 /* Having excluded floating point types, we know we are now dealing
1358 with signed integer types. */
1359 type = TREE_TYPE (args[0]);
1361 /* Args[0] is used multiple times below. */
1362 args[0] = gfc_evaluate_now (args[0], &se->pre);
1364 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1365 the signs of A and B are the same, and of all ones if they differ. */
1366 tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
1367 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
1368 build_int_cst (type, TYPE_PRECISION (type) - 1));
1369 tmp = gfc_evaluate_now (tmp, &se->pre);
1371 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1372 is all ones (i.e. -1). */
1373 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
1374 fold_build2_loc (input_location, PLUS_EXPR,
1375 type, args[0], tmp), tmp);
1379 /* Test for the presence of an optional argument. */
1382 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1386 arg = expr->value.function.actual->expr;
1387 gcc_assert (arg->expr_type == EXPR_VARIABLE);
1388 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1389 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1393 /* Calculate the double precision product of two single precision values. */
1396 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1401 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1403 /* Convert the args to double precision before multiplying. */
1404 type = gfc_typenode_for_spec (&expr->ts);
1405 args[0] = convert (type, args[0]);
1406 args[1] = convert (type, args[1]);
1407 se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
1412 /* Return a length one character string containing an ascii character. */
1415 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1420 unsigned int num_args;
1422 num_args = gfc_intrinsic_argument_list_length (expr);
1423 gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
1425 type = gfc_get_char_type (expr->ts.kind);
1426 var = gfc_create_var (type, "char");
1428 arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
1429 gfc_add_modify (&se->pre, var, arg[0]);
1430 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1431 se->string_length = integer_one_node;
1436 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1444 unsigned int num_args;
1446 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1447 args = XALLOCAVEC (tree, num_args);
1449 var = gfc_create_var (pchar_type_node, "pstr");
1450 len = gfc_create_var (gfc_get_int_type (8), "len");
1452 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1453 args[0] = gfc_build_addr_expr (NULL_TREE, var);
1454 args[1] = gfc_build_addr_expr (NULL_TREE, len);
1456 fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
1457 tmp = build_call_array_loc (input_location,
1458 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
1459 fndecl, num_args, args);
1460 gfc_add_expr_to_block (&se->pre, tmp);
1462 /* Free the temporary afterwards, if necessary. */
1463 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1464 len, build_int_cst (TREE_TYPE (len), 0));
1465 tmp = gfc_call_free (var);
1466 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1467 gfc_add_expr_to_block (&se->post, tmp);
1470 se->string_length = len;
1475 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1483 unsigned int num_args;
1485 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1486 args = XALLOCAVEC (tree, num_args);
1488 var = gfc_create_var (pchar_type_node, "pstr");
1489 len = gfc_create_var (gfc_charlen_type_node, "len");
1491 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1492 args[0] = gfc_build_addr_expr (NULL_TREE, var);
1493 args[1] = gfc_build_addr_expr (NULL_TREE, len);
1495 fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
1496 tmp = build_call_array_loc (input_location,
1497 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
1498 fndecl, num_args, args);
1499 gfc_add_expr_to_block (&se->pre, tmp);
1501 /* Free the temporary afterwards, if necessary. */
1502 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1503 len, build_int_cst (TREE_TYPE (len), 0));
1504 tmp = gfc_call_free (var);
1505 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1506 gfc_add_expr_to_block (&se->post, tmp);
1509 se->string_length = len;
1513 /* Return a character string containing the tty name. */
1516 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1524 unsigned int num_args;
1526 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1527 args = XALLOCAVEC (tree, num_args);
1529 var = gfc_create_var (pchar_type_node, "pstr");
1530 len = gfc_create_var (gfc_charlen_type_node, "len");
1532 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1533 args[0] = gfc_build_addr_expr (NULL_TREE, var);
1534 args[1] = gfc_build_addr_expr (NULL_TREE, len);
1536 fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
1537 tmp = build_call_array_loc (input_location,
1538 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
1539 fndecl, num_args, args);
1540 gfc_add_expr_to_block (&se->pre, tmp);
1542 /* Free the temporary afterwards, if necessary. */
1543 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1544 len, build_int_cst (TREE_TYPE (len), 0));
1545 tmp = gfc_call_free (var);
1546 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1547 gfc_add_expr_to_block (&se->post, tmp);
1550 se->string_length = len;
1554 /* Get the minimum/maximum value of all the parameters.
1555 minmax (a1, a2, a3, ...)
1558 if (a2 .op. mvar || isnan(mvar))
1560 if (a3 .op. mvar || isnan(mvar))
1567 /* TODO: Mismatching types can occur when specific names are used.
1568 These should be handled during resolution. */
1570 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
1578 gfc_actual_arglist *argexpr;
1579 unsigned int i, nargs;
1581 nargs = gfc_intrinsic_argument_list_length (expr);
1582 args = XALLOCAVEC (tree, nargs);
1584 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
1585 type = gfc_typenode_for_spec (&expr->ts);
1587 argexpr = expr->value.function.actual;
1588 if (TREE_TYPE (args[0]) != type)
1589 args[0] = convert (type, args[0]);
1590 /* Only evaluate the argument once. */
1591 if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
1592 args[0] = gfc_evaluate_now (args[0], &se->pre);
1594 mvar = gfc_create_var (type, "M");
1595 gfc_add_modify (&se->pre, mvar, args[0]);
1596 for (i = 1, argexpr = argexpr->next; i < nargs; i++)
1602 /* Handle absent optional arguments by ignoring the comparison. */
1603 if (argexpr->expr->expr_type == EXPR_VARIABLE
1604 && argexpr->expr->symtree->n.sym->attr.optional
1605 && TREE_CODE (val) == INDIRECT_REF)
1606 cond = fold_build2_loc (input_location,
1607 NE_EXPR, boolean_type_node,
1608 TREE_OPERAND (val, 0),
1609 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
1614 /* Only evaluate the argument once. */
1615 if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1616 val = gfc_evaluate_now (val, &se->pre);
1619 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1621 tmp = fold_build2_loc (input_location, op, boolean_type_node,
1622 convert (type, val), mvar);
1624 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1625 __builtin_isnan might be made dependent on that module being loaded,
1626 to help performance of programs that don't rely on IEEE semantics. */
1627 if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
1629 isnan = build_call_expr_loc (input_location,
1630 built_in_decls[BUILT_IN_ISNAN], 1, mvar);
1631 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1632 boolean_type_node, tmp,
1633 fold_convert (boolean_type_node, isnan));
1635 tmp = build3_v (COND_EXPR, tmp, thencase,
1636 build_empty_stmt (input_location));
1638 if (cond != NULL_TREE)
1639 tmp = build3_v (COND_EXPR, cond, tmp,
1640 build_empty_stmt (input_location));
1642 gfc_add_expr_to_block (&se->pre, tmp);
1643 argexpr = argexpr->next;
1649 /* Generate library calls for MIN and MAX intrinsics for character
1652 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
1655 tree var, len, fndecl, tmp, cond, function;
1658 nargs = gfc_intrinsic_argument_list_length (expr);
1659 args = XALLOCAVEC (tree, nargs + 4);
1660 gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
1662 /* Create the result variables. */
1663 len = gfc_create_var (gfc_charlen_type_node, "len");
1664 args[0] = gfc_build_addr_expr (NULL_TREE, len);
1665 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
1666 args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
1667 args[2] = build_int_cst (NULL_TREE, op);
1668 args[3] = build_int_cst (NULL_TREE, nargs / 2);
1670 if (expr->ts.kind == 1)
1671 function = gfor_fndecl_string_minmax;
1672 else if (expr->ts.kind == 4)
1673 function = gfor_fndecl_string_minmax_char4;
1677 /* Make the function call. */
1678 fndecl = build_addr (function, current_function_decl);
1679 tmp = build_call_array_loc (input_location,
1680 TREE_TYPE (TREE_TYPE (function)), fndecl,
1682 gfc_add_expr_to_block (&se->pre, tmp);
1684 /* Free the temporary afterwards, if necessary. */
1685 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1686 len, build_int_cst (TREE_TYPE (len), 0));
1687 tmp = gfc_call_free (var);
1688 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1689 gfc_add_expr_to_block (&se->post, tmp);
1692 se->string_length = len;
1696 /* Create a symbol node for this intrinsic. The symbol from the frontend
1697 has the generic name. */
1700 gfc_get_symbol_for_expr (gfc_expr * expr)
1704 /* TODO: Add symbols for intrinsic function to the global namespace. */
1705 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1706 sym = gfc_new_symbol (expr->value.function.name, NULL);
1709 sym->attr.external = 1;
1710 sym->attr.function = 1;
1711 sym->attr.always_explicit = 1;
1712 sym->attr.proc = PROC_INTRINSIC;
1713 sym->attr.flavor = FL_PROCEDURE;
1717 sym->attr.dimension = 1;
1718 sym->as = gfc_get_array_spec ();
1719 sym->as->type = AS_ASSUMED_SHAPE;
1720 sym->as->rank = expr->rank;
1723 gfc_copy_formal_args_intr (sym, expr->value.function.isym);
1728 /* Generate a call to an external intrinsic function. */
1730 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1733 VEC(tree,gc) *append_args;
1735 gcc_assert (!se->ss || se->ss->expr == expr);
1738 gcc_assert (expr->rank > 0);
1740 gcc_assert (expr->rank == 0);
1742 sym = gfc_get_symbol_for_expr (expr);
1744 /* Calls to libgfortran_matmul need to be appended special arguments,
1745 to be able to call the BLAS ?gemm functions if required and possible. */
1747 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
1748 && sym->ts.type != BT_LOGICAL)
1750 tree cint = gfc_get_int_type (gfc_c_int_kind);
1752 if (gfc_option.flag_external_blas
1753 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1754 && (sym->ts.kind == gfc_default_real_kind
1755 || sym->ts.kind == gfc_default_double_kind))
1759 if (sym->ts.type == BT_REAL)
1761 if (sym->ts.kind == gfc_default_real_kind)
1762 gemm_fndecl = gfor_fndecl_sgemm;
1764 gemm_fndecl = gfor_fndecl_dgemm;
1768 if (sym->ts.kind == gfc_default_real_kind)
1769 gemm_fndecl = gfor_fndecl_cgemm;
1771 gemm_fndecl = gfor_fndecl_zgemm;
1774 append_args = VEC_alloc (tree, gc, 3);
1775 VEC_quick_push (tree, append_args, build_int_cst (cint, 1));
1776 VEC_quick_push (tree, append_args,
1777 build_int_cst (cint, gfc_option.blas_matmul_limit));
1778 VEC_quick_push (tree, append_args,
1779 gfc_build_addr_expr (NULL_TREE, gemm_fndecl));
1783 append_args = VEC_alloc (tree, gc, 3);
1784 VEC_quick_push (tree, append_args, build_int_cst (cint, 0));
1785 VEC_quick_push (tree, append_args, build_int_cst (cint, 0));
1786 VEC_quick_push (tree, append_args, null_pointer_node);
1790 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
1795 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1815 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
1824 gfc_actual_arglist *actual;
1831 gfc_conv_intrinsic_funcall (se, expr);
1835 actual = expr->value.function.actual;
1836 type = gfc_typenode_for_spec (&expr->ts);
1837 /* Initialize the result. */
1838 resvar = gfc_create_var (type, "test");
1840 tmp = convert (type, boolean_true_node);
1842 tmp = convert (type, boolean_false_node);
1843 gfc_add_modify (&se->pre, resvar, tmp);
1845 /* Walk the arguments. */
1846 arrayss = gfc_walk_expr (actual->expr);
1847 gcc_assert (arrayss != gfc_ss_terminator);
1849 /* Initialize the scalarizer. */
1850 gfc_init_loopinfo (&loop);
1851 exit_label = gfc_build_label_decl (NULL_TREE);
1852 TREE_USED (exit_label) = 1;
1853 gfc_add_ss_to_loop (&loop, arrayss);
1855 /* Initialize the loop. */
1856 gfc_conv_ss_startstride (&loop);
1857 gfc_conv_loop_setup (&loop, &expr->where);
1859 gfc_mark_ss_chain_used (arrayss, 1);
1860 /* Generate the loop body. */
1861 gfc_start_scalarized_body (&loop, &body);
1863 /* If the condition matches then set the return value. */
1864 gfc_start_block (&block);
1866 tmp = convert (type, boolean_false_node);
1868 tmp = convert (type, boolean_true_node);
1869 gfc_add_modify (&block, resvar, tmp);
1871 /* And break out of the loop. */
1872 tmp = build1_v (GOTO_EXPR, exit_label);
1873 gfc_add_expr_to_block (&block, tmp);
1875 found = gfc_finish_block (&block);
1877 /* Check this element. */
1878 gfc_init_se (&arrayse, NULL);
1879 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1880 arrayse.ss = arrayss;
1881 gfc_conv_expr_val (&arrayse, actual->expr);
1883 gfc_add_block_to_block (&body, &arrayse.pre);
1884 tmp = fold_build2_loc (input_location, op, boolean_type_node, arrayse.expr,
1885 build_int_cst (TREE_TYPE (arrayse.expr), 0));
1886 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
1887 gfc_add_expr_to_block (&body, tmp);
1888 gfc_add_block_to_block (&body, &arrayse.post);
1890 gfc_trans_scalarizing_loops (&loop, &body);
1892 /* Add the exit label. */
1893 tmp = build1_v (LABEL_EXPR, exit_label);
1894 gfc_add_expr_to_block (&loop.pre, tmp);
1896 gfc_add_block_to_block (&se->pre, &loop.pre);
1897 gfc_add_block_to_block (&se->pre, &loop.post);
1898 gfc_cleanup_loop (&loop);
1903 /* COUNT(A) = Number of true elements in A. */
1905 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1912 gfc_actual_arglist *actual;
1918 gfc_conv_intrinsic_funcall (se, expr);
1922 actual = expr->value.function.actual;
1924 type = gfc_typenode_for_spec (&expr->ts);
1925 /* Initialize the result. */
1926 resvar = gfc_create_var (type, "count");
1927 gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
1929 /* Walk the arguments. */
1930 arrayss = gfc_walk_expr (actual->expr);
1931 gcc_assert (arrayss != gfc_ss_terminator);
1933 /* Initialize the scalarizer. */
1934 gfc_init_loopinfo (&loop);
1935 gfc_add_ss_to_loop (&loop, arrayss);
1937 /* Initialize the loop. */
1938 gfc_conv_ss_startstride (&loop);
1939 gfc_conv_loop_setup (&loop, &expr->where);
1941 gfc_mark_ss_chain_used (arrayss, 1);
1942 /* Generate the loop body. */
1943 gfc_start_scalarized_body (&loop, &body);
1945 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
1946 resvar, build_int_cst (TREE_TYPE (resvar), 1));
1947 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1949 gfc_init_se (&arrayse, NULL);
1950 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1951 arrayse.ss = arrayss;
1952 gfc_conv_expr_val (&arrayse, actual->expr);
1953 tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
1954 build_empty_stmt (input_location));
1956 gfc_add_block_to_block (&body, &arrayse.pre);
1957 gfc_add_expr_to_block (&body, tmp);
1958 gfc_add_block_to_block (&body, &arrayse.post);
1960 gfc_trans_scalarizing_loops (&loop, &body);
1962 gfc_add_block_to_block (&se->pre, &loop.pre);
1963 gfc_add_block_to_block (&se->pre, &loop.post);
1964 gfc_cleanup_loop (&loop);
1969 /* Inline implementation of the sum and product intrinsics. */
1971 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
1975 tree scale = NULL_TREE;
1981 gfc_actual_arglist *actual;
1986 gfc_expr *arrayexpr;
1991 gfc_conv_intrinsic_funcall (se, expr);
1995 type = gfc_typenode_for_spec (&expr->ts);
1996 /* Initialize the result. */
1997 resvar = gfc_create_var (type, "val");
2002 scale = gfc_create_var (type, "scale");
2003 gfc_add_modify (&se->pre, scale,
2004 gfc_build_const (type, integer_one_node));
2005 tmp = gfc_build_const (type, integer_zero_node);
2007 else if (op == PLUS_EXPR)
2008 tmp = gfc_build_const (type, integer_zero_node);
2009 else if (op == NE_EXPR)
2011 tmp = convert (type, boolean_false_node);
2013 tmp = gfc_build_const (type, integer_one_node);
2015 gfc_add_modify (&se->pre, resvar, tmp);
2017 /* Walk the arguments. */
2018 actual = expr->value.function.actual;
2019 arrayexpr = actual->expr;
2020 arrayss = gfc_walk_expr (arrayexpr);
2021 gcc_assert (arrayss != gfc_ss_terminator);
2023 if (op == NE_EXPR || norm2)
2024 /* PARITY and NORM2. */
2028 actual = actual->next->next;
2029 gcc_assert (actual);
2030 maskexpr = actual->expr;
2033 if (maskexpr && maskexpr->rank != 0)
2035 maskss = gfc_walk_expr (maskexpr);
2036 gcc_assert (maskss != gfc_ss_terminator);
2041 /* Initialize the scalarizer. */
2042 gfc_init_loopinfo (&loop);
2043 gfc_add_ss_to_loop (&loop, arrayss);
2045 gfc_add_ss_to_loop (&loop, maskss);
2047 /* Initialize the loop. */
2048 gfc_conv_ss_startstride (&loop);
2049 gfc_conv_loop_setup (&loop, &expr->where);
2051 gfc_mark_ss_chain_used (arrayss, 1);
2053 gfc_mark_ss_chain_used (maskss, 1);
2054 /* Generate the loop body. */
2055 gfc_start_scalarized_body (&loop, &body);
2057 /* If we have a mask, only add this element if the mask is set. */
2060 gfc_init_se (&maskse, NULL);
2061 gfc_copy_loopinfo_to_se (&maskse, &loop);
2063 gfc_conv_expr_val (&maskse, maskexpr);
2064 gfc_add_block_to_block (&body, &maskse.pre);
2066 gfc_start_block (&block);
2069 gfc_init_block (&block);
2071 /* Do the actual summation/product. */
2072 gfc_init_se (&arrayse, NULL);
2073 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2074 arrayse.ss = arrayss;
2075 gfc_conv_expr_val (&arrayse, arrayexpr);
2076 gfc_add_block_to_block (&block, &arrayse.pre);
2086 result = 1.0 + result * val * val;
2092 result += val * val;
2095 tree res1, res2, cond, absX, val;
2096 stmtblock_t ifblock1, ifblock2, ifblock3;
2098 gfc_init_block (&ifblock1);
2100 absX = gfc_create_var (type, "absX");
2101 gfc_add_modify (&ifblock1, absX,
2102 fold_build1_loc (input_location, ABS_EXPR, type,
2104 val = gfc_create_var (type, "val");
2105 gfc_add_expr_to_block (&ifblock1, val);
2107 gfc_init_block (&ifblock2);
2108 gfc_add_modify (&ifblock2, val,
2109 fold_build2_loc (input_location, RDIV_EXPR, type, scale,
2111 res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
2112 res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
2113 res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
2114 gfc_build_const (type, integer_one_node));
2115 gfc_add_modify (&ifblock2, resvar, res1);
2116 gfc_add_modify (&ifblock2, scale, absX);
2117 res1 = gfc_finish_block (&ifblock2);
2119 gfc_init_block (&ifblock3);
2120 gfc_add_modify (&ifblock3, val,
2121 fold_build2_loc (input_location, RDIV_EXPR, type, absX,
2123 res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
2124 res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
2125 gfc_add_modify (&ifblock3, resvar, res2);
2126 res2 = gfc_finish_block (&ifblock3);
2128 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2130 tmp = build3_v (COND_EXPR, cond, res1, res2);
2131 gfc_add_expr_to_block (&ifblock1, tmp);
2132 tmp = gfc_finish_block (&ifblock1);
2134 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2136 gfc_build_const (type, integer_zero_node));
2138 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2139 gfc_add_expr_to_block (&block, tmp);
2143 tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
2144 gfc_add_modify (&block, resvar, tmp);
2147 gfc_add_block_to_block (&block, &arrayse.post);
2151 /* We enclose the above in if (mask) {...} . */
2153 tmp = gfc_finish_block (&block);
2154 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2155 build_empty_stmt (input_location));
2158 tmp = gfc_finish_block (&block);
2159 gfc_add_expr_to_block (&body, tmp);
2161 gfc_trans_scalarizing_loops (&loop, &body);
2163 /* For a scalar mask, enclose the loop in an if statement. */
2164 if (maskexpr && maskss == NULL)
2166 gfc_init_se (&maskse, NULL);
2167 gfc_conv_expr_val (&maskse, maskexpr);
2168 gfc_init_block (&block);
2169 gfc_add_block_to_block (&block, &loop.pre);
2170 gfc_add_block_to_block (&block, &loop.post);
2171 tmp = gfc_finish_block (&block);
2173 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2174 build_empty_stmt (input_location));
2175 gfc_add_expr_to_block (&block, tmp);
2176 gfc_add_block_to_block (&se->pre, &block);
2180 gfc_add_block_to_block (&se->pre, &loop.pre);
2181 gfc_add_block_to_block (&se->pre, &loop.post);
2184 gfc_cleanup_loop (&loop);
2188 /* result = scale * sqrt(result). */
2190 sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
2191 resvar = build_call_expr_loc (input_location,
2193 resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
2200 /* Inline implementation of the dot_product intrinsic. This function
2201 is based on gfc_conv_intrinsic_arith (the previous function). */
2203 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2211 gfc_actual_arglist *actual;
2212 gfc_ss *arrayss1, *arrayss2;
2213 gfc_se arrayse1, arrayse2;
2214 gfc_expr *arrayexpr1, *arrayexpr2;
2216 type = gfc_typenode_for_spec (&expr->ts);
2218 /* Initialize the result. */
2219 resvar = gfc_create_var (type, "val");
2220 if (expr->ts.type == BT_LOGICAL)
2221 tmp = build_int_cst (type, 0);
2223 tmp = gfc_build_const (type, integer_zero_node);
2225 gfc_add_modify (&se->pre, resvar, tmp);
2227 /* Walk argument #1. */
2228 actual = expr->value.function.actual;
2229 arrayexpr1 = actual->expr;
2230 arrayss1 = gfc_walk_expr (arrayexpr1);
2231 gcc_assert (arrayss1 != gfc_ss_terminator);
2233 /* Walk argument #2. */
2234 actual = actual->next;
2235 arrayexpr2 = actual->expr;
2236 arrayss2 = gfc_walk_expr (arrayexpr2);
2237 gcc_assert (arrayss2 != gfc_ss_terminator);
2239 /* Initialize the scalarizer. */
2240 gfc_init_loopinfo (&loop);
2241 gfc_add_ss_to_loop (&loop, arrayss1);
2242 gfc_add_ss_to_loop (&loop, arrayss2);
2244 /* Initialize the loop. */
2245 gfc_conv_ss_startstride (&loop);
2246 gfc_conv_loop_setup (&loop, &expr->where);
2248 gfc_mark_ss_chain_used (arrayss1, 1);
2249 gfc_mark_ss_chain_used (arrayss2, 1);
2251 /* Generate the loop body. */
2252 gfc_start_scalarized_body (&loop, &body);
2253 gfc_init_block (&block);
2255 /* Make the tree expression for [conjg(]array1[)]. */
2256 gfc_init_se (&arrayse1, NULL);
2257 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2258 arrayse1.ss = arrayss1;
2259 gfc_conv_expr_val (&arrayse1, arrayexpr1);
2260 if (expr->ts.type == BT_COMPLEX)
2261 arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
2263 gfc_add_block_to_block (&block, &arrayse1.pre);
2265 /* Make the tree expression for array2. */
2266 gfc_init_se (&arrayse2, NULL);
2267 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2268 arrayse2.ss = arrayss2;
2269 gfc_conv_expr_val (&arrayse2, arrayexpr2);
2270 gfc_add_block_to_block (&block, &arrayse2.pre);
2272 /* Do the actual product and sum. */
2273 if (expr->ts.type == BT_LOGICAL)
2275 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
2276 arrayse1.expr, arrayse2.expr);
2277 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
2281 tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
2283 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
2285 gfc_add_modify (&block, resvar, tmp);
2287 /* Finish up the loop block and the loop. */
2288 tmp = gfc_finish_block (&block);
2289 gfc_add_expr_to_block (&body, tmp);
2291 gfc_trans_scalarizing_loops (&loop, &body);
2292 gfc_add_block_to_block (&se->pre, &loop.pre);
2293 gfc_add_block_to_block (&se->pre, &loop.post);
2294 gfc_cleanup_loop (&loop);
2300 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2301 we need to handle. For performance reasons we sometimes create two
2302 loops instead of one, where the second one is much simpler.
2303 Examples for minloc intrinsic:
2304 1) Result is an array, a call is generated
2305 2) Array mask is used and NaNs need to be supported:
2311 if (pos == 0) pos = S + (1 - from);
2312 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2319 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2323 3) NaNs need to be supported, but it is known at compile time or cheaply
2324 at runtime whether array is nonempty or not:
2329 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2332 if (from <= to) pos = 1;
2336 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2340 4) NaNs aren't supported, array mask is used:
2341 limit = infinities_supported ? Infinity : huge (limit);
2345 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2351 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2355 5) Same without array mask:
2356 limit = infinities_supported ? Infinity : huge (limit);
2357 pos = (from <= to) ? 1 : 0;
2360 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2363 For 3) and 5), if mask is scalar, this all goes into a conditional,
2364 setting pos = 0; in the else branch. */
2367 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
2371 stmtblock_t ifblock;
2372 stmtblock_t elseblock;
2383 gfc_actual_arglist *actual;
2388 gfc_expr *arrayexpr;
2395 gfc_conv_intrinsic_funcall (se, expr);
2399 /* Initialize the result. */
2400 pos = gfc_create_var (gfc_array_index_type, "pos");
2401 offset = gfc_create_var (gfc_array_index_type, "offset");
2402 type = gfc_typenode_for_spec (&expr->ts);
2404 /* Walk the arguments. */
2405 actual = expr->value.function.actual;
2406 arrayexpr = actual->expr;
2407 arrayss = gfc_walk_expr (arrayexpr);
2408 gcc_assert (arrayss != gfc_ss_terminator);
2410 actual = actual->next->next;
2411 gcc_assert (actual);
2412 maskexpr = actual->expr;
2414 if (maskexpr && maskexpr->rank != 0)
2416 maskss = gfc_walk_expr (maskexpr);
2417 gcc_assert (maskss != gfc_ss_terminator);
2422 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
2424 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
2426 nonempty = fold_build2_loc (input_location, GT_EXPR,
2427 boolean_type_node, nonempty,
2428 gfc_index_zero_node);
2433 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2434 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2435 switch (arrayexpr->ts.type)
2438 if (HONOR_INFINITIES (DECL_MODE (limit)))
2440 REAL_VALUE_TYPE real;
2442 tmp = build_real (TREE_TYPE (limit), real);
2445 tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2446 arrayexpr->ts.kind, 0);
2450 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2451 arrayexpr->ts.kind);
2458 /* We start with the most negative possible value for MAXLOC, and the most
2459 positive possible value for MINLOC. The most negative possible value is
2460 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2461 possible value is HUGE in both cases. */
2463 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2464 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2465 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
2466 build_int_cst (type, 1));
2468 gfc_add_modify (&se->pre, limit, tmp);
2470 /* Initialize the scalarizer. */
2471 gfc_init_loopinfo (&loop);
2472 gfc_add_ss_to_loop (&loop, arrayss);
2474 gfc_add_ss_to_loop (&loop, maskss);
2476 /* Initialize the loop. */
2477 gfc_conv_ss_startstride (&loop);
2478 gfc_conv_loop_setup (&loop, &expr->where);
2480 gcc_assert (loop.dimen == 1);
2481 if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
2482 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
2483 loop.from[0], loop.to[0]);
2487 /* Initialize the position to zero, following Fortran 2003. We are free
2488 to do this because Fortran 95 allows the result of an entirely false
2489 mask to be processor dependent. If we know at compile time the array
2490 is non-empty and no MASK is used, we can initialize to 1 to simplify
2492 if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
2493 gfc_add_modify (&loop.pre, pos,
2494 fold_build3_loc (input_location, COND_EXPR,
2495 gfc_array_index_type,
2496 nonempty, gfc_index_one_node,
2497 gfc_index_zero_node));
2500 gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
2501 lab1 = gfc_build_label_decl (NULL_TREE);
2502 TREE_USED (lab1) = 1;
2503 lab2 = gfc_build_label_decl (NULL_TREE);
2504 TREE_USED (lab2) = 1;
2507 gfc_mark_ss_chain_used (arrayss, 1);
2509 gfc_mark_ss_chain_used (maskss, 1);
2510 /* Generate the loop body. */
2511 gfc_start_scalarized_body (&loop, &body);
2513 /* If we have a mask, only check this element if the mask is set. */
2516 gfc_init_se (&maskse, NULL);
2517 gfc_copy_loopinfo_to_se (&maskse, &loop);
2519 gfc_conv_expr_val (&maskse, maskexpr);
2520 gfc_add_block_to_block (&body, &maskse.pre);
2522 gfc_start_block (&block);
2525 gfc_init_block (&block);
2527 /* Compare with the current limit. */
2528 gfc_init_se (&arrayse, NULL);
2529 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2530 arrayse.ss = arrayss;
2531 gfc_conv_expr_val (&arrayse, arrayexpr);
2532 gfc_add_block_to_block (&block, &arrayse.pre);
2534 /* We do the following if this is a more extreme value. */
2535 gfc_start_block (&ifblock);
2537 /* Assign the value to the limit... */
2538 gfc_add_modify (&ifblock, limit, arrayse.expr);
2540 /* Remember where we are. An offset must be added to the loop
2541 counter to obtain the required position. */
2543 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2544 gfc_index_one_node, loop.from[0]);
2546 tmp = gfc_index_one_node;
2548 gfc_add_modify (&block, offset, tmp);
2550 if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
2552 stmtblock_t ifblock2;
2555 gfc_start_block (&ifblock2);
2556 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
2557 loop.loopvar[0], offset);
2558 gfc_add_modify (&ifblock2, pos, tmp);
2559 ifbody2 = gfc_finish_block (&ifblock2);
2560 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pos,
2561 gfc_index_zero_node);
2562 tmp = build3_v (COND_EXPR, cond, ifbody2,
2563 build_empty_stmt (input_location));
2564 gfc_add_expr_to_block (&block, tmp);
2567 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
2568 loop.loopvar[0], offset);
2569 gfc_add_modify (&ifblock, pos, tmp);
2572 gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
2574 ifbody = gfc_finish_block (&ifblock);
2576 if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
2579 cond = fold_build2_loc (input_location,
2580 op == GT_EXPR ? GE_EXPR : LE_EXPR,
2581 boolean_type_node, arrayse.expr, limit);
2583 cond = fold_build2_loc (input_location, op, boolean_type_node,
2584 arrayse.expr, limit);
2586 ifbody = build3_v (COND_EXPR, cond, ifbody,
2587 build_empty_stmt (input_location));
2589 gfc_add_expr_to_block (&block, ifbody);
2593 /* We enclose the above in if (mask) {...}. */
2594 tmp = gfc_finish_block (&block);
2596 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2597 build_empty_stmt (input_location));
2600 tmp = gfc_finish_block (&block);
2601 gfc_add_expr_to_block (&body, tmp);
2605 gfc_trans_scalarized_loop_end (&loop, 0, &body);
2607 if (HONOR_NANS (DECL_MODE (limit)))
2609 if (nonempty != NULL)
2611 ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
2612 tmp = build3_v (COND_EXPR, nonempty, ifbody,
2613 build_empty_stmt (input_location));
2614 gfc_add_expr_to_block (&loop.code[0], tmp);
2618 gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
2619 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
2620 gfc_start_block (&body);
2622 /* If we have a mask, only check this element if the mask is set. */
2625 gfc_init_se (&maskse, NULL);
2626 gfc_copy_loopinfo_to_se (&maskse, &loop);
2628 gfc_conv_expr_val (&maskse, maskexpr);
2629 gfc_add_block_to_block (&body, &maskse.pre);
2631 gfc_start_block (&block);
2634 gfc_init_block (&block);
2636 /* Compare with the current limit. */
2637 gfc_init_se (&arrayse, NULL);
2638 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2639 arrayse.ss = arrayss;
2640 gfc_conv_expr_val (&arrayse, arrayexpr);
2641 gfc_add_block_to_block (&block, &arrayse.pre);
2643 /* We do the following if this is a more extreme value. */
2644 gfc_start_block (&ifblock);
2646 /* Assign the value to the limit... */
2647 gfc_add_modify (&ifblock, limit, arrayse.expr);
2649 /* Remember where we are. An offset must be added to the loop
2650 counter to obtain the required position. */
2652 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2653 gfc_index_one_node, loop.from[0]);
2655 tmp = gfc_index_one_node;
2657 gfc_add_modify (&block, offset, tmp);
2659 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
2660 loop.loopvar[0], offset);
2661 gfc_add_modify (&ifblock, pos, tmp);
2663 ifbody = gfc_finish_block (&ifblock);
2665 cond = fold_build2_loc (input_location, op, boolean_type_node,
2666 arrayse.expr, limit);
2668 tmp = build3_v (COND_EXPR, cond, ifbody,
2669 build_empty_stmt (input_location));
2670 gfc_add_expr_to_block (&block, tmp);
2674 /* We enclose the above in if (mask) {...}. */
2675 tmp = gfc_finish_block (&block);
2677 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2678 build_empty_stmt (input_location));
2681 tmp = gfc_finish_block (&block);
2682 gfc_add_expr_to_block (&body, tmp);
2683 /* Avoid initializing loopvar[0] again, it should be left where
2684 it finished by the first loop. */
2685 loop.from[0] = loop.loopvar[0];
2688 gfc_trans_scalarizing_loops (&loop, &body);
2691 gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
2693 /* For a scalar mask, enclose the loop in an if statement. */
2694 if (maskexpr && maskss == NULL)
2696 gfc_init_se (&maskse, NULL);
2697 gfc_conv_expr_val (&maskse, maskexpr);
2698 gfc_init_block (&block);
2699 gfc_add_block_to_block (&block, &loop.pre);
2700 gfc_add_block_to_block (&block, &loop.post);
2701 tmp = gfc_finish_block (&block);
2703 /* For the else part of the scalar mask, just initialize
2704 the pos variable the same way as above. */
2706 gfc_init_block (&elseblock);
2707 gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
2708 elsetmp = gfc_finish_block (&elseblock);
2710 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2711 gfc_add_expr_to_block (&block, tmp);
2712 gfc_add_block_to_block (&se->pre, &block);
2716 gfc_add_block_to_block (&se->pre, &loop.pre);
2717 gfc_add_block_to_block (&se->pre, &loop.post);
2719 gfc_cleanup_loop (&loop);
2721 se->expr = convert (type, pos);
2724 /* Emit code for minval or maxval intrinsic. There are many different cases
2725 we need to handle. For performance reasons we sometimes create two
2726 loops instead of one, where the second one is much simpler.
2727 Examples for minval intrinsic:
2728 1) Result is an array, a call is generated
2729 2) Array mask is used and NaNs need to be supported, rank 1:
2734 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
2737 limit = nonempty ? NaN : huge (limit);
2739 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
2740 3) NaNs need to be supported, but it is known at compile time or cheaply
2741 at runtime whether array is nonempty or not, rank 1:
2744 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
2745 limit = (from <= to) ? NaN : huge (limit);
2747 while (S <= to) { limit = min (a[S], limit); S++; }
2748 4) Array mask is used and NaNs need to be supported, rank > 1:
2757 if (fast) limit = min (a[S1][S2], limit);
2760 if (a[S1][S2] <= limit) {
2771 limit = nonempty ? NaN : huge (limit);
2772 5) NaNs need to be supported, but it is known at compile time or cheaply
2773 at runtime whether array is nonempty or not, rank > 1:
2780 if (fast) limit = min (a[S1][S2], limit);
2782 if (a[S1][S2] <= limit) {
2792 limit = (nonempty_array) ? NaN : huge (limit);
2793 6) NaNs aren't supported, but infinities are. Array mask is used:
2798 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
2801 limit = nonempty ? limit : huge (limit);
2802 7) Same without array mask:
2805 while (S <= to) { limit = min (a[S], limit); S++; }
2806 limit = (from <= to) ? limit : huge (limit);
2807 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
2808 limit = huge (limit);
2810 while (S <= to) { limit = min (a[S], limit); S++); }
2812 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
2813 with array mask instead).
2814 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
2815 setting limit = huge (limit); in the else branch. */
2818 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
2828 tree huge_cst = NULL, nan_cst = NULL;
2830 stmtblock_t block, block2;
2832 gfc_actual_arglist *actual;
2837 gfc_expr *arrayexpr;
2843 gfc_conv_intrinsic_funcall (se, expr);
2847 type = gfc_typenode_for_spec (&expr->ts);
2848 /* Initialize the result. */
2849 limit = gfc_create_var (type, "limit");
2850 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2851 switch (expr->ts.type)
2854 huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2856 if (HONOR_INFINITIES (DECL_MODE (limit)))
2858 REAL_VALUE_TYPE real;
2860 tmp = build_real (type, real);
2864 if (HONOR_NANS (DECL_MODE (limit)))
2866 REAL_VALUE_TYPE real;
2867 real_nan (&real, "", 1, DECL_MODE (limit));
2868 nan_cst = build_real (type, real);
2873 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2880 /* We start with the most negative possible value for MAXVAL, and the most
2881 positive possible value for MINVAL. The most negative possible value is
2882 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2883 possible value is HUGE in both cases. */
2886 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2888 huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
2889 TREE_TYPE (huge_cst), huge_cst);
2892 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2893 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
2894 tmp, build_int_cst (type, 1));
2896 gfc_add_modify (&se->pre, limit, tmp);
2898 /* Walk the arguments. */
2899 actual = expr->value.function.actual;
2900 arrayexpr = actual->expr;
2901 arrayss = gfc_walk_expr (arrayexpr);
2902 gcc_assert (arrayss != gfc_ss_terminator);
2904 actual = actual->next->next;
2905 gcc_assert (actual);
2906 maskexpr = actual->expr;
2908 if (maskexpr && maskexpr->rank != 0)
2910 maskss = gfc_walk_expr (maskexpr);
2911 gcc_assert (maskss != gfc_ss_terminator);
2916 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
2918 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
2920 nonempty = fold_build2_loc (input_location, GT_EXPR,
2921 boolean_type_node, nonempty,
2922 gfc_index_zero_node);
2927 /* Initialize the scalarizer. */
2928 gfc_init_loopinfo (&loop);
2929 gfc_add_ss_to_loop (&loop, arrayss);
2931 gfc_add_ss_to_loop (&loop, maskss);
2933 /* Initialize the loop. */
2934 gfc_conv_ss_startstride (&loop);
2935 gfc_conv_loop_setup (&loop, &expr->where);
2937 if (nonempty == NULL && maskss == NULL
2938 && loop.dimen == 1 && loop.from[0] && loop.to[0])
2939 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
2940 loop.from[0], loop.to[0]);
2941 nonempty_var = NULL;
2942 if (nonempty == NULL
2943 && (HONOR_INFINITIES (DECL_MODE (limit))
2944 || HONOR_NANS (DECL_MODE (limit))))
2946 nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
2947 gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
2948 nonempty = nonempty_var;
2952 if (HONOR_NANS (DECL_MODE (limit)))
2954 if (loop.dimen == 1)
2956 lab = gfc_build_label_decl (NULL_TREE);
2957 TREE_USED (lab) = 1;
2961 fast = gfc_create_var (boolean_type_node, "fast");
2962 gfc_add_modify (&se->pre, fast, boolean_false_node);
2966 gfc_mark_ss_chain_used (arrayss, 1);
2968 gfc_mark_ss_chain_used (maskss, 1);
2969 /* Generate the loop body. */
2970 gfc_start_scalarized_body (&loop, &body);
2972 /* If we have a mask, only add this element if the mask is set. */
2975 gfc_init_se (&maskse, NULL);
2976 gfc_copy_loopinfo_to_se (&maskse, &loop);
2978 gfc_conv_expr_val (&maskse, maskexpr);
2979 gfc_add_block_to_block (&body, &maskse.pre);
2981 gfc_start_block (&block);
2984 gfc_init_block (&block);
2986 /* Compare with the current limit. */
2987 gfc_init_se (&arrayse, NULL);
2988 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2989 arrayse.ss = arrayss;
2990 gfc_conv_expr_val (&arrayse, arrayexpr);
2991 gfc_add_block_to_block (&block, &arrayse.pre);
2993 gfc_init_block (&block2);
2996 gfc_add_modify (&block2, nonempty_var, boolean_true_node);
2998 if (HONOR_NANS (DECL_MODE (limit)))
3000 tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
3001 boolean_type_node, arrayse.expr, limit);
3003 ifbody = build1_v (GOTO_EXPR, lab);
3006 stmtblock_t ifblock;
3008 gfc_init_block (&ifblock);
3009 gfc_add_modify (&ifblock, limit, arrayse.expr);
3010 gfc_add_modify (&ifblock, fast, boolean_true_node);
3011 ifbody = gfc_finish_block (&ifblock);
3013 tmp = build3_v (COND_EXPR, tmp, ifbody,
3014 build_empty_stmt (input_location));
3015 gfc_add_expr_to_block (&block2, tmp);
3019 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3021 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3023 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3024 arrayse.expr, limit);
3025 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3026 tmp = build3_v (COND_EXPR, tmp, ifbody,
3027 build_empty_stmt (input_location));
3028 gfc_add_expr_to_block (&block2, tmp);
3032 tmp = fold_build2_loc (input_location,
3033 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3034 type, arrayse.expr, limit);
3035 gfc_add_modify (&block2, limit, tmp);
3041 tree elsebody = gfc_finish_block (&block2);
3043 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3045 if (HONOR_NANS (DECL_MODE (limit))
3046 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3048 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3049 arrayse.expr, limit);
3050 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3051 ifbody = build3_v (COND_EXPR, tmp, ifbody,
3052 build_empty_stmt (input_location));
3056 tmp = fold_build2_loc (input_location,
3057 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3058 type, arrayse.expr, limit);
3059 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
3061 tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
3062 gfc_add_expr_to_block (&block, tmp);
3065 gfc_add_block_to_block (&block, &block2);
3067 gfc_add_block_to_block (&block, &arrayse.post);
3069 tmp = gfc_finish_block (&block);
3071 /* We enclose the above in if (mask) {...}. */
3072 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3073 build_empty_stmt (input_location));
3074 gfc_add_expr_to_block (&body, tmp);
3078 gfc_trans_scalarized_loop_end (&loop, 0, &body);
3080 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
3082 gfc_add_modify (&loop.code[0], limit, tmp);
3083 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
3085 gfc_start_block (&body);
3087 /* If we have a mask, only add this element if the mask is set. */
3090 gfc_init_se (&maskse, NULL);
3091 gfc_copy_loopinfo_to_se (&maskse, &loop);
3093 gfc_conv_expr_val (&maskse, maskexpr);
3094 gfc_add_block_to_block (&body, &maskse.pre);
3096 gfc_start_block (&block);
3099 gfc_init_block (&block);
3101 /* Compare with the current limit. */
3102 gfc_init_se (&arrayse, NULL);
3103 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3104 arrayse.ss = arrayss;
3105 gfc_conv_expr_val (&arrayse, arrayexpr);
3106 gfc_add_block_to_block (&block, &arrayse.pre);
3108 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3110 if (HONOR_NANS (DECL_MODE (limit))
3111 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3113 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3114 arrayse.expr, limit);
3115 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3116 tmp = build3_v (COND_EXPR, tmp, ifbody,
3117 build_empty_stmt (input_location));
3118 gfc_add_expr_to_block (&block, tmp);
3122 tmp = fold_build2_loc (input_location,
3123 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3124 type, arrayse.expr, limit);
3125 gfc_add_modify (&block, limit, tmp);
3128 gfc_add_block_to_block (&block, &arrayse.post);
3130 tmp = gfc_finish_block (&block);
3132 /* We enclose the above in if (mask) {...}. */
3133 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3134 build_empty_stmt (input_location));
3135 gfc_add_expr_to_block (&body, tmp);
3136 /* Avoid initializing loopvar[0] again, it should be left where
3137 it finished by the first loop. */
3138 loop.from[0] = loop.loopvar[0];
3140 gfc_trans_scalarizing_loops (&loop, &body);
3144 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
3146 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
3147 tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
3149 gfc_add_expr_to_block (&loop.pre, tmp);
3151 else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
3153 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
3155 gfc_add_modify (&loop.pre, limit, tmp);
3158 /* For a scalar mask, enclose the loop in an if statement. */
3159 if (maskexpr && maskss == NULL)
3163 gfc_init_se (&maskse, NULL);
3164 gfc_conv_expr_val (&maskse, maskexpr);
3165 gfc_init_block (&block);
3166 gfc_add_block_to_block (&block, &loop.pre);
3167 gfc_add_block_to_block (&block, &loop.post);
3168 tmp = gfc_finish_block (&block);
3170 if (HONOR_INFINITIES (DECL_MODE (limit)))
3171 else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
3173 else_stmt = build_empty_stmt (input_location);
3174 tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
3175 gfc_add_expr_to_block (&block, tmp);
3176 gfc_add_block_to_block (&se->pre, &block);
3180 gfc_add_block_to_block (&se->pre, &loop.pre);
3181 gfc_add_block_to_block (&se->pre, &loop.post);
3184 gfc_cleanup_loop (&loop);
3189 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3191 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
3197 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3198 type = TREE_TYPE (args[0]);
3200 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3201 build_int_cst (type, 1), args[1]);
3202 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
3203 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
3204 build_int_cst (type, 0));
3205 type = gfc_typenode_for_spec (&expr->ts);
3206 se->expr = convert (type, tmp);
3209 /* Generate code to perform the specified operation. */
3211 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
3215 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3216 se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
3222 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
3226 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3227 se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
3228 TREE_TYPE (arg), arg);
3231 /* Set or clear a single bit. */
3233 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
3240 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3241 type = TREE_TYPE (args[0]);
3243 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3244 build_int_cst (type, 1), args[1]);
3250 tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
3252 se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
3255 /* Extract a sequence of bits.
3256 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3258 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
3265 gfc_conv_intrinsic_function_args (se, expr, args, 3);
3266 type = TREE_TYPE (args[0]);
3268 mask = build_int_cst (type, -1);
3269 mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
3270 mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
3272 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
3274 se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
3277 /* RSHIFT (I, SHIFT) = I >> SHIFT
3278 LSHIFT (I, SHIFT) = I << SHIFT */
3280 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
3284 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3286 se->expr = fold_build2_loc (input_location,
3287 right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
3288 TREE_TYPE (args[0]), args[0], args[1]);
3291 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
3293 : ((shift >= 0) ? i << shift : i >> -shift)
3294 where all shifts are logical shifts. */
3296 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
3308 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3310 args[0] = gfc_evaluate_now (args[0], &se->pre);
3311 args[1] = gfc_evaluate_now (args[1], &se->pre);
3313 type = TREE_TYPE (args[0]);
3314 utype = unsigned_type_for (type);
3316 width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
3319 /* Left shift if positive. */
3320 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
3322 /* Right shift if negative.
3323 We convert to an unsigned type because we want a logical shift.
3324 The standard doesn't define the case of shifting negative
3325 numbers, and we try to be compatible with other compilers, most
3326 notably g77, here. */
3327 rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
3328 utype, convert (utype, args[0]), width));
3330 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, args[1],
3331 build_int_cst (TREE_TYPE (args[1]), 0));
3332 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
3334 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3335 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3337 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
3338 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, width,
3340 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
3341 build_int_cst (type, 0), tmp);
3345 /* Circular shift. AKA rotate or barrel shift. */
3348 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
3356 unsigned int num_args;
3358 num_args = gfc_intrinsic_argument_list_length (expr);
3359 args = XALLOCAVEC (tree, num_args);
3361 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3365 /* Use a library function for the 3 parameter version. */
3366 tree int4type = gfc_get_int_type (4);
3368 type = TREE_TYPE (args[0]);
3369 /* We convert the first argument to at least 4 bytes, and
3370 convert back afterwards. This removes the need for library
3371 functions for all argument sizes, and function will be
3372 aligned to at least 32 bits, so there's no loss. */
3373 if (expr->ts.kind < 4)
3374 args[0] = convert (int4type, args[0]);
3376 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
3377 need loads of library functions. They cannot have values >
3378 BIT_SIZE (I) so the conversion is safe. */
3379 args[1] = convert (int4type, args[1]);
3380 args[2] = convert (int4type, args[2]);
3382 switch (expr->ts.kind)
3387 tmp = gfor_fndecl_math_ishftc4;
3390 tmp = gfor_fndecl_math_ishftc8;
3393 tmp = gfor_fndecl_math_ishftc16;
3398 se->expr = build_call_expr_loc (input_location,
3399 tmp, 3, args[0], args[1], args[2]);
3400 /* Convert the result back to the original type, if we extended
3401 the first argument's width above. */
3402 if (expr->ts.kind < 4)
3403 se->expr = convert (type, se->expr);
3407 type = TREE_TYPE (args[0]);
3409 /* Evaluate arguments only once. */
3410 args[0] = gfc_evaluate_now (args[0], &se->pre);
3411 args[1] = gfc_evaluate_now (args[1], &se->pre);
3413 /* Rotate left if positive. */
3414 lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
3416 /* Rotate right if negative. */
3417 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
3419 rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
3421 zero = build_int_cst (TREE_TYPE (args[1]), 0);
3422 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, args[1],
3424 rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
3426 /* Do nothing if shift == 0. */
3427 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, args[1],
3429 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
3433 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
3434 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
3436 The conditional expression is necessary because the result of LEADZ(0)
3437 is defined, but the result of __builtin_clz(0) is undefined for most
3440 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
3441 difference in bit size between the argument of LEADZ and the C int. */
3444 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
3456 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3457 argsize = TYPE_PRECISION (TREE_TYPE (arg));
3459 /* Which variant of __builtin_clz* should we call? */
3460 if (argsize <= INT_TYPE_SIZE)
3462 arg_type = unsigned_type_node;
3463 func = built_in_decls[BUILT_IN_CLZ];
3465 else if (argsize <= LONG_TYPE_SIZE)
3467 arg_type = long_unsigned_type_node;
3468 func = built_in_decls[BUILT_IN_CLZL];
3470 else if (argsize <= LONG_LONG_TYPE_SIZE)
3472 arg_type = long_long_unsigned_type_node;
3473 func = built_in_decls[BUILT_IN_CLZLL];
3477 gcc_assert (argsize == 128);
3478 arg_type = gfc_build_uint_type (argsize);
3479 func = gfor_fndecl_clz128;
3482 /* Convert the actual argument twice: first, to the unsigned type of the
3483 same size; then, to the proper argument type for the built-in
3484 function. But the return type is of the default INTEGER kind. */
3485 arg = fold_convert (gfc_build_uint_type (argsize), arg);
3486 arg = fold_convert (arg_type, arg);
3487 result_type = gfc_get_int_type (gfc_default_integer_kind);
3489 /* Compute LEADZ for the case i .ne. 0. */
3490 s = TYPE_PRECISION (arg_type) - argsize;
3491 tmp = fold_convert (result_type, build_call_expr_loc (input_location, func,
3493 leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
3494 tmp, build_int_cst (result_type, s));
3496 /* Build BIT_SIZE. */
3497 bit_size = build_int_cst (result_type, argsize);
3499 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3500 arg, build_int_cst (arg_type, 0));
3501 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
3505 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
3507 The conditional expression is necessary because the result of TRAILZ(0)
3508 is defined, but the result of __builtin_ctz(0) is undefined for most
3512 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
3523 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3524 argsize = TYPE_PRECISION (TREE_TYPE (arg));
3526 /* Which variant of __builtin_ctz* should we call? */
3527 if (argsize <= INT_TYPE_SIZE)
3529 arg_type = unsigned_type_node;
3530 func = built_in_decls[BUILT_IN_CTZ];
3532 else if (argsize <= LONG_TYPE_SIZE)
3534 arg_type = long_unsigned_type_node;
3535 func = built_in_decls[BUILT_IN_CTZL];
3537 else if (argsize <= LONG_LONG_TYPE_SIZE)
3539 arg_type = long_long_unsigned_type_node;
3540 func = built_in_decls[BUILT_IN_CTZLL];
3544 gcc_assert (argsize == 128);
3545 arg_type = gfc_build_uint_type (argsize);
3546 func = gfor_fndecl_ctz128;
3549 /* Convert the actual argument twice: first, to the unsigned type of the
3550 same size; then, to the proper argument type for the built-in
3551 function. But the return type is of the default INTEGER kind. */
3552 arg = fold_convert (gfc_build_uint_type (argsize), arg);
3553 arg = fold_convert (arg_type, arg);
3554 result_type = gfc_get_int_type (gfc_default_integer_kind);
3556 /* Compute TRAILZ for the case i .ne. 0. */
3557 trailz = fold_convert (result_type, build_call_expr_loc (input_location,
3560 /* Build BIT_SIZE. */
3561 bit_size = build_int_cst (result_type, argsize);
3563 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3564 arg, build_int_cst (arg_type, 0));
3565 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
3569 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
3570 for types larger than "long long", we call the long long built-in for
3571 the lower and higher bits and combine the result. */
3574 gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
3582 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3583 argsize = TYPE_PRECISION (TREE_TYPE (arg));
3584 result_type = gfc_get_int_type (gfc_default_integer_kind);
3586 /* Which variant of the builtin should we call? */
3587 if (argsize <= INT_TYPE_SIZE)
3589 arg_type = unsigned_type_node;
3590 func = built_in_decls[parity ? BUILT_IN_PARITY : BUILT_IN_POPCOUNT];
3592 else if (argsize <= LONG_TYPE_SIZE)
3594 arg_type = long_unsigned_type_node;
3595 func = built_in_decls[parity ? BUILT_IN_PARITYL : BUILT_IN_POPCOUNTL];
3597 else if (argsize <= LONG_LONG_TYPE_SIZE)
3599 arg_type = long_long_unsigned_type_node;
3600 func = built_in_decls[parity ? BUILT_IN_PARITYLL : BUILT_IN_POPCOUNTLL];
3604 /* Our argument type is larger than 'long long', which mean none
3605 of the POPCOUNT builtins covers it. We thus call the 'long long'
3606 variant multiple times, and add the results. */
3607 tree utype, arg2, call1, call2;
3609 /* For now, we only cover the case where argsize is twice as large
3611 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
3613 func = built_in_decls[parity ? BUILT_IN_PARITYLL : BUILT_IN_POPCOUNTLL];
3615 /* Convert it to an integer, and store into a variable. */
3616 utype = gfc_build_uint_type (argsize);
3617 arg = fold_convert (utype, arg);
3618 arg = gfc_evaluate_now (arg, &se->pre);
3620 /* Call the builtin twice. */
3621 call1 = build_call_expr_loc (input_location, func, 1,
3622 fold_convert (long_long_unsigned_type_node,
3625 arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
3626 build_int_cst (utype, LONG_LONG_TYPE_SIZE));
3627 call2 = build_call_expr_loc (input_location, func, 1,
3628 fold_convert (long_long_unsigned_type_node,
3631 /* Combine the results. */
3633 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type,
3636 se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type,
3642 /* Convert the actual argument twice: first, to the unsigned type of the
3643 same size; then, to the proper argument type for the built-in
3645 arg = fold_convert (gfc_build_uint_type (argsize), arg);
3646 arg = fold_convert (arg_type, arg);
3648 se->expr = fold_convert (result_type,
3649 build_call_expr_loc (input_location, func, 1, arg));
3653 /* Process an intrinsic with unspecified argument-types that has an optional
3654 argument (which could be of type character), e.g. EOSHIFT. For those, we
3655 need to append the string length of the optional argument if it is not
3656 present and the type is really character.
3657 primary specifies the position (starting at 1) of the non-optional argument
3658 specifying the type and optional gives the position of the optional
3659 argument in the arglist. */
3662 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
3663 unsigned primary, unsigned optional)
3665 gfc_actual_arglist* prim_arg;
3666 gfc_actual_arglist* opt_arg;
3668 gfc_actual_arglist* arg;
3670 VEC(tree,gc) *append_args;
3672 /* Find the two arguments given as position. */
3676 for (arg = expr->value.function.actual; arg; arg = arg->next)
3680 if (cur_pos == primary)
3682 if (cur_pos == optional)
3685 if (cur_pos >= primary && cur_pos >= optional)
3688 gcc_assert (prim_arg);
3689 gcc_assert (prim_arg->expr);
3690 gcc_assert (opt_arg);
3692 /* If we do have type CHARACTER and the optional argument is really absent,
3693 append a dummy 0 as string length. */
3695 if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
3699 dummy = build_int_cst (gfc_charlen_type_node, 0);
3700 append_args = VEC_alloc (tree, gc, 1);
3701 VEC_quick_push (tree, append_args, dummy);
3704 /* Build the call itself. */
3705 sym = gfc_get_symbol_for_expr (expr);
3706 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3712 /* The length of a character string. */
3714 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
3724 gcc_assert (!se->ss);
3726 arg = expr->value.function.actual->expr;
3728 type = gfc_typenode_for_spec (&expr->ts);
3729 switch (arg->expr_type)
3732 len = build_int_cst (NULL_TREE, arg->value.character.length);
3736 /* Obtain the string length from the function used by
3737 trans-array.c(gfc_trans_array_constructor). */
3739 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
3743 if (arg->ref == NULL
3744 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
3746 /* This doesn't catch all cases.
3747 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
3748 and the surrounding thread. */
3749 sym = arg->symtree->n.sym;
3750 decl = gfc_get_symbol_decl (sym);
3751 if (decl == current_function_decl && sym->attr.function
3752 && (sym->result == sym))
3753 decl = gfc_get_fake_result_decl (sym, 0);
3755 len = sym->ts.u.cl->backend_decl;
3760 /* Otherwise fall through. */
3763 /* Anybody stupid enough to do this deserves inefficient code. */
3764 ss = gfc_walk_expr (arg);
3765 gfc_init_se (&argse, se);
3766 if (ss == gfc_ss_terminator)
3767 gfc_conv_expr (&argse, arg);
3769 gfc_conv_expr_descriptor (&argse, arg, ss);
3770 gfc_add_block_to_block (&se->pre, &argse.pre);
3771 gfc_add_block_to_block (&se->post, &argse.post);
3772 len = argse.string_length;
3775 se->expr = convert (type, len);
3778 /* The length of a character string not including trailing blanks. */
3780 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
3782 int kind = expr->value.function.actual->expr->ts.kind;
3783 tree args[2], type, fndecl;
3785 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3786 type = gfc_typenode_for_spec (&expr->ts);
3789 fndecl = gfor_fndecl_string_len_trim;
3791 fndecl = gfor_fndecl_string_len_trim_char4;
3795 se->expr = build_call_expr_loc (input_location,
3796 fndecl, 2, args[0], args[1]);
3797 se->expr = convert (type, se->expr);
3801 /* Returns the starting position of a substring within a string. */
3804 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
3807 tree logical4_type_node = gfc_get_logical_type (4);
3811 unsigned int num_args;
3813 args = XALLOCAVEC (tree, 5);
3815 /* Get number of arguments; characters count double due to the
3816 string length argument. Kind= is not passed to the library
3817 and thus ignored. */
3818 if (expr->value.function.actual->next->next->expr == NULL)
3823 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3824 type = gfc_typenode_for_spec (&expr->ts);
3827 args[4] = build_int_cst (logical4_type_node, 0);
3829 args[4] = convert (logical4_type_node, args[4]);
3831 fndecl = build_addr (function, current_function_decl);
3832 se->expr = build_call_array_loc (input_location,
3833 TREE_TYPE (TREE_TYPE (function)), fndecl,
3835 se->expr = convert (type, se->expr);
3839 /* The ascii value for a single character. */
3841 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
3843 tree args[2], type, pchartype;
3845 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3846 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
3847 pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
3848 args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
3849 type = gfc_typenode_for_spec (&expr->ts);
3851 se->expr = build_fold_indirect_ref_loc (input_location,
3853 se->expr = convert (type, se->expr);
3857 /* Intrinsic ISNAN calls __builtin_isnan. */
3860 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
3864 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3865 se->expr = build_call_expr_loc (input_location,
3866 built_in_decls[BUILT_IN_ISNAN], 1, arg);
3867 STRIP_TYPE_NOPS (se->expr);
3868 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3872 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
3873 their argument against a constant integer value. */
3876 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
3880 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3881 se->expr = fold_build2_loc (input_location, EQ_EXPR,
3882 gfc_typenode_for_spec (&expr->ts),
3883 arg, build_int_cst (TREE_TYPE (arg), value));
3888 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
3891 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
3899 unsigned int num_args;
3901 num_args = gfc_intrinsic_argument_list_length (expr);
3902 args = XALLOCAVEC (tree, num_args);
3904 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3905 if (expr->ts.type != BT_CHARACTER)
3913 /* We do the same as in the non-character case, but the argument
3914 list is different because of the string length arguments. We
3915 also have to set the string length for the result. */
3922 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
3924 se->string_length = len;
3926 type = TREE_TYPE (tsource);
3927 se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
3928 fold_convert (type, fsource));
3932 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
3934 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
3936 tree arg, type, tmp, frexp;
3938 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
3940 type = gfc_typenode_for_spec (&expr->ts);
3941 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3942 tmp = gfc_create_var (integer_type_node, NULL);
3943 se->expr = build_call_expr_loc (input_location, frexp, 2,
3944 fold_convert (type, arg),
3945 gfc_build_addr_expr (NULL_TREE, tmp));
3946 se->expr = fold_convert (type, se->expr);
3950 /* NEAREST (s, dir) is translated into
3951 tmp = copysign (HUGE_VAL, dir);
3952 return nextafter (s, tmp);
3955 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
3957 tree args[2], type, tmp, nextafter, copysign, huge_val;
3959 nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
3960 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
3961 huge_val = gfc_builtin_decl_for_float_kind (BUILT_IN_HUGE_VAL, expr->ts.kind);
3963 type = gfc_typenode_for_spec (&expr->ts);
3964 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3965 tmp = build_call_expr_loc (input_location, copysign, 2,
3966 build_call_expr_loc (input_location, huge_val, 0),
3967 fold_convert (type, args[1]));
3968 se->expr = build_call_expr_loc (input_location, nextafter, 2,
3969 fold_convert (type, args[0]), tmp);
3970 se->expr = fold_convert (type, se->expr);
3974 /* SPACING (s) is translated into
3982 e = MAX_EXPR (e, emin);
3983 res = scalbn (1., e);
3987 where prec is the precision of s, gfc_real_kinds[k].digits,
3988 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
3989 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
3992 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
3994 tree arg, type, prec, emin, tiny, res, e;
3995 tree cond, tmp, frexp, scalbn;
3999 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
4000 prec = build_int_cst (NULL_TREE, gfc_real_kinds[k].digits);
4001 emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1);
4002 tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
4004 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4005 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4007 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4008 arg = gfc_evaluate_now (arg, &se->pre);
4010 type = gfc_typenode_for_spec (&expr->ts);
4011 e = gfc_create_var (integer_type_node, NULL);
4012 res = gfc_create_var (type, NULL);
4015 /* Build the block for s /= 0. */
4016 gfc_start_block (&block);
4017 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
4018 gfc_build_addr_expr (NULL_TREE, e));
4019 gfc_add_expr_to_block (&block, tmp);
4021 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
4023 gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
4024 integer_type_node, tmp, emin));
4026 tmp = build_call_expr_loc (input_location, scalbn, 2,
4027 build_real_from_int_cst (type, integer_one_node), e);
4028 gfc_add_modify (&block, res, tmp);
4030 /* Finish by building the IF statement. */
4031 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
4032 build_real_from_int_cst (type, integer_zero_node));
4033 tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
4034 gfc_finish_block (&block));
4036 gfc_add_expr_to_block (&se->pre, tmp);
4041 /* RRSPACING (s) is translated into
4048 x = scalbn (x, precision - e);
4052 where precision is gfc_real_kinds[k].digits. */
4055 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
4057 tree arg, type, e, x, cond, stmt, tmp, frexp, scalbn, fabs;
4061 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
4062 prec = gfc_real_kinds[k].digits;
4064 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4065 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4066 fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
4068 type = gfc_typenode_for_spec (&expr->ts);
4069 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4070 arg = gfc_evaluate_now (arg, &se->pre);
4072 e = gfc_create_var (integer_type_node, NULL);
4073 x = gfc_create_var (type, NULL);
4074 gfc_add_modify (&se->pre, x,
4075 build_call_expr_loc (input_location, fabs, 1, arg));
4078 gfc_start_block (&block);
4079 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
4080 gfc_build_addr_expr (NULL_TREE, e));
4081 gfc_add_expr_to_block (&block, tmp);
4083 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4084 build_int_cst (NULL_TREE, prec), e);
4085 tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
4086 gfc_add_modify (&block, x, tmp);
4087 stmt = gfc_finish_block (&block);
4089 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, x,
4090 build_real_from_int_cst (type, integer_zero_node));
4091 tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
4092 gfc_add_expr_to_block (&se->pre, tmp);
4094 se->expr = fold_convert (type, x);
4098 /* SCALE (s, i) is translated into scalbn (s, i). */
4100 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
4102 tree args[2], type, scalbn;
4104 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4106 type = gfc_typenode_for_spec (&expr->ts);
4107 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4108 se->expr = build_call_expr_loc (input_location, scalbn, 2,
4109 fold_convert (type, args[0]),
4110 fold_convert (integer_type_node, args[1]));
4111 se->expr = fold_convert (type, se->expr);
4115 /* SET_EXPONENT (s, i) is translated into
4116 scalbn (frexp (s, &dummy_int), i). */
4118 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
4120 tree args[2], type, tmp, frexp, scalbn;
4122 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4123 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4125 type = gfc_typenode_for_spec (&expr->ts);
4126 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4128 tmp = gfc_create_var (integer_type_node, NULL);
4129 tmp = build_call_expr_loc (input_location, frexp, 2,
4130 fold_convert (type, args[0]),
4131 gfc_build_addr_expr (NULL_TREE, tmp));
4132 se->expr = build_call_expr_loc (input_location, scalbn, 2, tmp,
4133 fold_convert (integer_type_node, args[1]));
4134 se->expr = fold_convert (type, se->expr);
4139 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
4141 gfc_actual_arglist *actual;
4149 gfc_init_se (&argse, NULL);
4150 actual = expr->value.function.actual;
4152 ss = gfc_walk_expr (actual->expr);
4153 gcc_assert (ss != gfc_ss_terminator);
4154 argse.want_pointer = 1;
4155 argse.data_not_needed = 1;
4156 gfc_conv_expr_descriptor (&argse, actual->expr, ss);
4157 gfc_add_block_to_block (&se->pre, &argse.pre);
4158 gfc_add_block_to_block (&se->post, &argse.post);
4159 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
4161 /* Build the call to size0. */
4162 fncall0 = build_call_expr_loc (input_location,
4163 gfor_fndecl_size0, 1, arg1);
4165 actual = actual->next;
4169 gfc_init_se (&argse, NULL);
4170 gfc_conv_expr_type (&argse, actual->expr,
4171 gfc_array_index_type);
4172 gfc_add_block_to_block (&se->pre, &argse.pre);
4174 /* Unusually, for an intrinsic, size does not exclude
4175 an optional arg2, so we must test for it. */
4176 if (actual->expr->expr_type == EXPR_VARIABLE
4177 && actual->expr->symtree->n.sym->attr.dummy
4178 && actual->expr->symtree->n.sym->attr.optional)
4181 /* Build the call to size1. */
4182 fncall1 = build_call_expr_loc (input_location,
4183 gfor_fndecl_size1, 2,
4186 gfc_init_se (&argse, NULL);
4187 argse.want_pointer = 1;
4188 argse.data_not_needed = 1;
4189 gfc_conv_expr (&argse, actual->expr);
4190 gfc_add_block_to_block (&se->pre, &argse.pre);
4191 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4192 argse.expr, null_pointer_node);
4193 tmp = gfc_evaluate_now (tmp, &se->pre);
4194 se->expr = fold_build3_loc (input_location, COND_EXPR,
4195 pvoid_type_node, tmp, fncall1, fncall0);
4199 se->expr = NULL_TREE;
4200 argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
4201 gfc_array_index_type,
4202 argse.expr, gfc_index_one_node);
4205 else if (expr->value.function.actual->expr->rank == 1)
4207 argse.expr = gfc_index_zero_node;
4208 se->expr = NULL_TREE;
4213 if (se->expr == NULL_TREE)
4215 tree ubound, lbound;
4217 arg1 = build_fold_indirect_ref_loc (input_location,
4219 ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
4220 lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
4221 se->expr = fold_build2_loc (input_location, MINUS_EXPR,
4222 gfc_array_index_type, ubound, lbound);
4223 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
4224 gfc_array_index_type,
4225 se->expr, gfc_index_one_node);
4226 se->expr = fold_build2_loc (input_location, MAX_EXPR,
4227 gfc_array_index_type, se->expr,
4228 gfc_index_zero_node);
4231 type = gfc_typenode_for_spec (&expr->ts);
4232 se->expr = convert (type, se->expr);
4236 /* Helper function to compute the size of a character variable,
4237 excluding the terminating null characters. The result has
4238 gfc_array_index_type type. */
4241 size_of_string_in_bytes (int kind, tree string_length)
4244 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
4246 bytesize = build_int_cst (gfc_array_index_type,
4247 gfc_character_kinds[i].bit_size / 8);
4249 return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4251 fold_convert (gfc_array_index_type, string_length));
4256 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
4268 arg = expr->value.function.actual->expr;
4270 gfc_init_se (&argse, NULL);
4271 ss = gfc_walk_expr (arg);
4273 if (ss == gfc_ss_terminator)
4275 if (arg->ts.type == BT_CLASS)
4276 gfc_add_component_ref (arg, "$data");
4278 gfc_conv_expr_reference (&argse, arg);
4280 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4283 /* Obtain the source word length. */
4284 if (arg->ts.type == BT_CHARACTER)
4285 se->expr = size_of_string_in_bytes (arg->ts.kind,
4286 argse.string_length);
4288 se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
4292 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
4293 argse.want_pointer = 0;
4294 gfc_conv_expr_descriptor (&argse, arg, ss);
4295 type = gfc_get_element_type (TREE_TYPE (argse.expr));
4297 /* Obtain the argument's word length. */
4298 if (arg->ts.type == BT_CHARACTER)
4299 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
4301 tmp = fold_convert (gfc_array_index_type,
4302 size_in_bytes (type));
4303 gfc_add_modify (&argse.pre, source_bytes, tmp);
4305 /* Obtain the size of the array in bytes. */
4306 for (n = 0; n < arg->rank; n++)
4309 idx = gfc_rank_cst[n];
4310 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
4311 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
4312 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4313 gfc_array_index_type, upper, lower);
4314 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4315 gfc_array_index_type, tmp, gfc_index_one_node);
4316 tmp = fold_build2_loc (input_location, MULT_EXPR,
4317 gfc_array_index_type, tmp, source_bytes);
4318 gfc_add_modify (&argse.pre, source_bytes, tmp);
4320 se->expr = source_bytes;
4323 gfc_add_block_to_block (&se->pre, &argse.pre);
4328 gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
4333 tree type, result_type, tmp;
4335 arg = expr->value.function.actual->expr;
4336 gfc_init_se (&eight, NULL);
4337 gfc_conv_expr (&eight, gfc_get_int_expr (expr->ts.kind, NULL, 8));
4339 gfc_init_se (&argse, NULL);
4340 ss = gfc_walk_expr (arg);
4341 result_type = gfc_get_int_type (expr->ts.kind);
4343 if (ss == gfc_ss_terminator)
4345 if (arg->ts.type == BT_CLASS)
4347 gfc_add_component_ref (arg, "$vptr");
4348 gfc_add_component_ref (arg, "$size");
4349 gfc_conv_expr (&argse, arg);
4350 tmp = fold_convert (result_type, argse.expr);
4354 gfc_conv_expr_reference (&argse, arg);
4355 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4360 argse.want_pointer = 0;
4361 gfc_conv_expr_descriptor (&argse, arg, ss);
4362 type = gfc_get_element_type (TREE_TYPE (argse.expr));
4365 /* Obtain the argument's word length. */
4366 if (arg->ts.type == BT_CHARACTER)
4367 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
4369 tmp = fold_convert (result_type, size_in_bytes (type));
4372 se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
4374 gfc_add_block_to_block (&se->pre, &argse.pre);
4378 /* Intrinsic string comparison functions. */
4381 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
4385 gfc_conv_intrinsic_function_args (se, expr, args, 4);
4388 = gfc_build_compare_string (args[0], args[1], args[2], args[3],
4389 expr->value.function.actual->expr->ts.kind,
4391 se->expr = fold_build2_loc (input_location, op,
4392 gfc_typenode_for_spec (&expr->ts), se->expr,
4393 build_int_cst (TREE_TYPE (se->expr), 0));
4396 /* Generate a call to the adjustl/adjustr library function. */
4398 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
4406 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
4409 type = TREE_TYPE (args[2]);
4410 var = gfc_conv_string_tmp (se, type, len);
4413 tmp = build_call_expr_loc (input_location,
4414 fndecl, 3, args[0], args[1], args[2]);
4415 gfc_add_expr_to_block (&se->pre, tmp);
4417 se->string_length = len;
4421 /* Generate code for the TRANSFER intrinsic:
4423 DEST = TRANSFER (SOURCE, MOLD)
4425 typeof<DEST> = typeof<MOLD>
4430 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
4432 typeof<DEST> = typeof<MOLD>
4434 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
4435 sizeof (DEST(0) * SIZE). */
4437 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
4453 gfc_actual_arglist *arg;
4463 info = &se->ss->data.info;
4465 /* Convert SOURCE. The output from this stage is:-
4466 source_bytes = length of the source in bytes
4467 source = pointer to the source data. */
4468 arg = expr->value.function.actual;
4470 /* Ensure double transfer through LOGICAL preserves all
4472 if (arg->expr->expr_type == EXPR_FUNCTION
4473 && arg->expr->value.function.esym == NULL
4474 && arg->expr->value.function.isym != NULL
4475 && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
4476 && arg->expr->ts.type == BT_LOGICAL
4477 && expr->ts.type != arg->expr->ts.type)
4478 arg->expr->value.function.name = "__transfer_in_transfer";
4480 gfc_init_se (&argse, NULL);
4481 ss = gfc_walk_expr (arg->expr);
4483 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
4485 /* Obtain the pointer to source and the length of source in bytes. */
4486 if (ss == gfc_ss_terminator)
4488 gfc_conv_expr_reference (&argse, arg->expr);
4489 source = argse.expr;
4491 source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4494 /* Obtain the source word length. */
4495 if (arg->expr->ts.type == BT_CHARACTER)
4496 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
4497 argse.string_length);
4499 tmp = fold_convert (gfc_array_index_type,
4500 size_in_bytes (source_type));
4504 argse.want_pointer = 0;
4505 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
4506 source = gfc_conv_descriptor_data_get (argse.expr);
4507 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
4509 /* Repack the source if not a full variable array. */
4510 if (arg->expr->expr_type == EXPR_VARIABLE
4511 && arg->expr->ref->u.ar.type != AR_FULL)
4513 tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
4515 if (gfc_option.warn_array_temp)
4516 gfc_warning ("Creating array temporary at %L", &expr->where);
4518 source = build_call_expr_loc (input_location,
4519 gfor_fndecl_in_pack, 1, tmp);
4520 source = gfc_evaluate_now (source, &argse.pre);
4522 /* Free the temporary. */
4523 gfc_start_block (&block);
4524 tmp = gfc_call_free (convert (pvoid_type_node, source));
4525 gfc_add_expr_to_block (&block, tmp);
4526 stmt = gfc_finish_block (&block);
4528 /* Clean up if it was repacked. */
4529 gfc_init_block (&block);
4530 tmp = gfc_conv_array_data (argse.expr);
4531 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4533 tmp = build3_v (COND_EXPR, tmp, stmt,
4534 build_empty_stmt (input_location));
4535 gfc_add_expr_to_block (&block, tmp);
4536 gfc_add_block_to_block (&block, &se->post);
4537 gfc_init_block (&se->post);
4538 gfc_add_block_to_block (&se->post, &block);
4541 /* Obtain the source word length. */
4542 if (arg->expr->ts.type == BT_CHARACTER)
4543 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
4544 argse.string_length);
4546 tmp = fold_convert (gfc_array_index_type,
4547 size_in_bytes (source_type));
4549 /* Obtain the size of the array in bytes. */
4550 extent = gfc_create_var (gfc_array_index_type, NULL);
4551 for (n = 0; n < arg->expr->rank; n++)
4554 idx = gfc_rank_cst[n];
4555 gfc_add_modify (&argse.pre, source_bytes, tmp);
4556 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
4557 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
4558 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4559 gfc_array_index_type, upper, lower);
4560 gfc_add_modify (&argse.pre, extent, tmp);
4561 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4562 gfc_array_index_type, extent,
4563 gfc_index_one_node);
4564 tmp = fold_build2_loc (input_location, MULT_EXPR,
4565 gfc_array_index_type, tmp, source_bytes);
4569 gfc_add_modify (&argse.pre, source_bytes, tmp);
4570 gfc_add_block_to_block (&se->pre, &argse.pre);
4571 gfc_add_block_to_block (&se->post, &argse.post);
4573 /* Now convert MOLD. The outputs are:
4574 mold_type = the TREE type of MOLD
4575 dest_word_len = destination word length in bytes. */
4578 gfc_init_se (&argse, NULL);
4579 ss = gfc_walk_expr (arg->expr);
4581 scalar_mold = arg->expr->rank == 0;
4583 if (ss == gfc_ss_terminator)
4585 gfc_conv_expr_reference (&argse, arg->expr);
4586 mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4591 gfc_init_se (&argse, NULL);
4592 argse.want_pointer = 0;
4593 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
4594 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
4597 gfc_add_block_to_block (&se->pre, &argse.pre);
4598 gfc_add_block_to_block (&se->post, &argse.post);
4600 if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
4602 /* If this TRANSFER is nested in another TRANSFER, use a type
4603 that preserves all bits. */
4604 if (arg->expr->ts.type == BT_LOGICAL)
4605 mold_type = gfc_get_int_type (arg->expr->ts.kind);
4608 if (arg->expr->ts.type == BT_CHARACTER)
4610 tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
4611 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
4614 tmp = fold_convert (gfc_array_index_type,
4615 size_in_bytes (mold_type));
4617 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
4618 gfc_add_modify (&se->pre, dest_word_len, tmp);
4620 /* Finally convert SIZE, if it is present. */
4622 size_words = gfc_create_var (gfc_array_index_type, NULL);
4626 gfc_init_se (&argse, NULL);
4627 gfc_conv_expr_reference (&argse, arg->expr);
4628 tmp = convert (gfc_array_index_type,
4629 build_fold_indirect_ref_loc (input_location,
4631 gfc_add_block_to_block (&se->pre, &argse.pre);
4632 gfc_add_block_to_block (&se->post, &argse.post);
4637 /* Separate array and scalar results. */
4638 if (scalar_mold && tmp == NULL_TREE)
4639 goto scalar_transfer;
4641 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
4642 if (tmp != NULL_TREE)
4643 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4644 tmp, dest_word_len);
4648 gfc_add_modify (&se->pre, size_bytes, tmp);
4649 gfc_add_modify (&se->pre, size_words,
4650 fold_build2_loc (input_location, CEIL_DIV_EXPR,
4651 gfc_array_index_type,
4652 size_bytes, dest_word_len));
4654 /* Evaluate the bounds of the result. If the loop range exists, we have
4655 to check if it is too large. If so, we modify loop->to be consistent
4656 with min(size, size(source)). Otherwise, size is made consistent with
4657 the loop range, so that the right number of bytes is transferred.*/
4658 n = se->loop->order[0];
4659 if (se->loop->to[n] != NULL_TREE)
4661 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4662 se->loop->to[n], se->loop->from[n]);
4663 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4664 tmp, gfc_index_one_node);
4665 tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
4667 gfc_add_modify (&se->pre, size_words, tmp);
4668 gfc_add_modify (&se->pre, size_bytes,
4669 fold_build2_loc (input_location, MULT_EXPR,
4670 gfc_array_index_type,
4671 size_words, dest_word_len));
4672 upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4673 size_words, se->loop->from[n]);
4674 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4675 upper, gfc_index_one_node);
4679 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4680 size_words, gfc_index_one_node);
4681 se->loop->from[n] = gfc_index_zero_node;
4684 se->loop->to[n] = upper;
4686 /* Build a destination descriptor, using the pointer, source, as the
4688 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
4689 info, mold_type, NULL_TREE, false, true, false,
4692 /* Cast the pointer to the result. */
4693 tmp = gfc_conv_descriptor_data_get (info->descriptor);
4694 tmp = fold_convert (pvoid_type_node, tmp);
4696 /* Use memcpy to do the transfer. */
4697 tmp = build_call_expr_loc (input_location,
4698 built_in_decls[BUILT_IN_MEMCPY],
4701 fold_convert (pvoid_type_node, source),
4702 fold_build2_loc (input_location, MIN_EXPR,
4703 gfc_array_index_type,
4704 size_bytes, source_bytes));
4705 gfc_add_expr_to_block (&se->pre, tmp);
4707 se->expr = info->descriptor;
4708 if (expr->ts.type == BT_CHARACTER)
4709 se->string_length = dest_word_len;
4713 /* Deal with scalar results. */
4715 extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
4716 dest_word_len, source_bytes);
4717 extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
4718 extent, gfc_index_zero_node);
4720 if (expr->ts.type == BT_CHARACTER)
4725 ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
4726 tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
4729 /* If source is longer than the destination, use a pointer to
4730 the source directly. */
4731 gfc_init_block (&block);
4732 gfc_add_modify (&block, tmpdecl, ptr);
4733 direct = gfc_finish_block (&block);
4735 /* Otherwise, allocate a string with the length of the destination
4736 and copy the source into it. */
4737 gfc_init_block (&block);
4738 tmp = gfc_get_pchar_type (expr->ts.kind);
4739 tmp = gfc_call_malloc (&block, tmp, dest_word_len);
4740 gfc_add_modify (&block, tmpdecl,
4741 fold_convert (TREE_TYPE (ptr), tmp));
4742 tmp = build_call_expr_loc (input_location,
4743 built_in_decls[BUILT_IN_MEMCPY], 3,
4744 fold_convert (pvoid_type_node, tmpdecl),
4745 fold_convert (pvoid_type_node, ptr),
4747 gfc_add_expr_to_block (&block, tmp);
4748 indirect = gfc_finish_block (&block);
4750 /* Wrap it up with the condition. */
4751 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
4752 dest_word_len, source_bytes);
4753 tmp = build3_v (COND_EXPR, tmp, direct, indirect);
4754 gfc_add_expr_to_block (&se->pre, tmp);
4757 se->string_length = dest_word_len;
4761 tmpdecl = gfc_create_var (mold_type, "transfer");
4763 ptr = convert (build_pointer_type (mold_type), source);
4765 /* Use memcpy to do the transfer. */
4766 tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
4767 tmp = build_call_expr_loc (input_location,
4768 built_in_decls[BUILT_IN_MEMCPY], 3,
4769 fold_convert (pvoid_type_node, tmp),
4770 fold_convert (pvoid_type_node, ptr),
4772 gfc_add_expr_to_block (&se->pre, tmp);
4779 /* Generate code for the ALLOCATED intrinsic.
4780 Generate inline code that directly check the address of the argument. */
4783 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
4785 gfc_actual_arglist *arg1;
4790 gfc_init_se (&arg1se, NULL);
4791 arg1 = expr->value.function.actual;
4792 ss1 = gfc_walk_expr (arg1->expr);
4794 if (ss1 == gfc_ss_terminator)
4796 /* Allocatable scalar. */
4797 arg1se.want_pointer = 1;
4798 if (arg1->expr->ts.type == BT_CLASS)
4799 gfc_add_component_ref (arg1->expr, "$data");
4800 gfc_conv_expr (&arg1se, arg1->expr);
4805 /* Allocatable array. */
4806 arg1se.descriptor_only = 1;
4807 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4808 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
4811 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
4812 fold_convert (TREE_TYPE (tmp), null_pointer_node));
4813 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
4817 /* Generate code for the ASSOCIATED intrinsic.
4818 If both POINTER and TARGET are arrays, generate a call to library function
4819 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
4820 In other cases, generate inline code that directly compare the address of
4821 POINTER with the address of TARGET. */
4824 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
4826 gfc_actual_arglist *arg1;
4827 gfc_actual_arglist *arg2;
4832 tree nonzero_charlen;
4833 tree nonzero_arraylen;
4836 gfc_init_se (&arg1se, NULL);
4837 gfc_init_se (&arg2se, NULL);
4838 arg1 = expr->value.function.actual;
4839 if (arg1->expr->ts.type == BT_CLASS)
4840 gfc_add_component_ref (arg1->expr, "$data");
4842 ss1 = gfc_walk_expr (arg1->expr);
4846 /* No optional target. */
4847 if (ss1 == gfc_ss_terminator)
4849 /* A pointer to a scalar. */
4850 arg1se.want_pointer = 1;
4851 gfc_conv_expr (&arg1se, arg1->expr);
4856 /* A pointer to an array. */
4857 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4858 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
4860 gfc_add_block_to_block (&se->pre, &arg1se.pre);
4861 gfc_add_block_to_block (&se->post, &arg1se.post);
4862 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2,
4863 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
4868 /* An optional target. */
4869 if (arg2->expr->ts.type == BT_CLASS)
4870 gfc_add_component_ref (arg2->expr, "$data");
4871 ss2 = gfc_walk_expr (arg2->expr);
4873 nonzero_charlen = NULL_TREE;
4874 if (arg1->expr->ts.type == BT_CHARACTER)
4875 nonzero_charlen = fold_build2_loc (input_location, NE_EXPR,
4877 arg1->expr->ts.u.cl->backend_decl,
4880 if (ss1 == gfc_ss_terminator)
4882 /* A pointer to a scalar. */
4883 gcc_assert (ss2 == gfc_ss_terminator);
4884 arg1se.want_pointer = 1;
4885 gfc_conv_expr (&arg1se, arg1->expr);
4886 arg2se.want_pointer = 1;
4887 gfc_conv_expr (&arg2se, arg2->expr);
4888 gfc_add_block_to_block (&se->pre, &arg1se.pre);
4889 gfc_add_block_to_block (&se->post, &arg1se.post);
4890 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4891 arg1se.expr, arg2se.expr);
4892 tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4893 arg1se.expr, null_pointer_node);
4894 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4895 boolean_type_node, tmp, tmp2);
4899 /* An array pointer of zero length is not associated if target is
4901 arg1se.descriptor_only = 1;
4902 gfc_conv_expr_lhs (&arg1se, arg1->expr);
4903 tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
4904 gfc_rank_cst[arg1->expr->rank - 1]);
4905 nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
4906 boolean_type_node, tmp,
4907 build_int_cst (TREE_TYPE (tmp), 0));
4909 /* A pointer to an array, call library function _gfor_associated. */
4910 gcc_assert (ss2 != gfc_ss_terminator);
4911 arg1se.want_pointer = 1;
4912 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4914 arg2se.want_pointer = 1;
4915 gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
4916 gfc_add_block_to_block (&se->pre, &arg2se.pre);
4917 gfc_add_block_to_block (&se->post, &arg2se.post);
4918 se->expr = build_call_expr_loc (input_location,
4919 gfor_fndecl_associated, 2,
4920 arg1se.expr, arg2se.expr);
4921 se->expr = convert (boolean_type_node, se->expr);
4922 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4923 boolean_type_node, se->expr,
4927 /* If target is present zero character length pointers cannot
4929 if (nonzero_charlen != NULL_TREE)
4930 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4932 se->expr, nonzero_charlen);
4935 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4939 /* Generate code for the SAME_TYPE_AS intrinsic.
4940 Generate inline code that directly checks the vindices. */
4943 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
4949 gfc_init_se (&se1, NULL);
4950 gfc_init_se (&se2, NULL);
4952 a = expr->value.function.actual->expr;
4953 b = expr->value.function.actual->next->expr;
4955 if (a->ts.type == BT_CLASS)
4957 gfc_add_component_ref (a, "$vptr");
4958 gfc_add_component_ref (a, "$hash");
4960 else if (a->ts.type == BT_DERIVED)
4961 a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4962 a->ts.u.derived->hash_value);
4964 if (b->ts.type == BT_CLASS)
4966 gfc_add_component_ref (b, "$vptr");
4967 gfc_add_component_ref (b, "$hash");
4969 else if (b->ts.type == BT_DERIVED)
4970 b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4971 b->ts.u.derived->hash_value);
4973 gfc_conv_expr (&se1, a);
4974 gfc_conv_expr (&se2, b);
4976 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4977 se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
4978 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
4982 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
4985 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
4989 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4990 se->expr = build_call_expr_loc (input_location,
4991 gfor_fndecl_sc_kind, 2, args[0], args[1]);
4992 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4996 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
4999 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
5003 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5005 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
5006 type = gfc_get_int_type (4);
5007 arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
5009 /* Convert it to the required type. */
5010 type = gfc_typenode_for_spec (&expr->ts);
5011 se->expr = build_call_expr_loc (input_location,
5012 gfor_fndecl_si_kind, 1, arg);
5013 se->expr = fold_convert (type, se->expr);
5017 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
5020 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
5022 gfc_actual_arglist *actual;
5025 VEC(tree,gc) *args = NULL;
5027 for (actual = expr->value.function.actual; actual; actual = actual->next)
5029 gfc_init_se (&argse, se);
5031 /* Pass a NULL pointer for an absent arg. */
5032 if (actual->expr == NULL)
5033 argse.expr = null_pointer_node;
5039 if (actual->expr->ts.kind != gfc_c_int_kind)
5041 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
5042 ts.type = BT_INTEGER;
5043 ts.kind = gfc_c_int_kind;
5044 gfc_convert_type (actual->expr, &ts, 2);
5046 gfc_conv_expr_reference (&argse, actual->expr);
5049 gfc_add_block_to_block (&se->pre, &argse.pre);
5050 gfc_add_block_to_block (&se->post, &argse.post);
5051 VEC_safe_push (tree, gc, args, argse.expr);
5054 /* Convert it to the required type. */
5055 type = gfc_typenode_for_spec (&expr->ts);
5056 se->expr = build_call_expr_loc_vec (input_location,
5057 gfor_fndecl_sr_kind, args);
5058 se->expr = fold_convert (type, se->expr);
5062 /* Generate code for TRIM (A) intrinsic function. */
5065 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
5075 unsigned int num_args;
5077 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
5078 args = XALLOCAVEC (tree, num_args);
5080 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
5081 addr = gfc_build_addr_expr (ppvoid_type_node, var);
5082 len = gfc_create_var (gfc_charlen_type_node, "len");
5084 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
5085 args[0] = gfc_build_addr_expr (NULL_TREE, len);
5088 if (expr->ts.kind == 1)
5089 function = gfor_fndecl_string_trim;
5090 else if (expr->ts.kind == 4)
5091 function = gfor_fndecl_string_trim_char4;
5095 fndecl = build_addr (function, current_function_decl);
5096 tmp = build_call_array_loc (input_location,
5097 TREE_TYPE (TREE_TYPE (function)), fndecl,
5099 gfc_add_expr_to_block (&se->pre, tmp);
5101 /* Free the temporary afterwards, if necessary. */
5102 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
5103 len, build_int_cst (TREE_TYPE (len), 0));
5104 tmp = gfc_call_free (var);
5105 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
5106 gfc_add_expr_to_block (&se->post, tmp);
5109 se->string_length = len;
5113 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
5116 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
5118 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
5119 tree type, cond, tmp, count, exit_label, n, max, largest;
5121 stmtblock_t block, body;
5124 /* We store in charsize the size of a character. */
5125 i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
5126 size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
5128 /* Get the arguments. */
5129 gfc_conv_intrinsic_function_args (se, expr, args, 3);
5130 slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
5132 ncopies = gfc_evaluate_now (args[2], &se->pre);
5133 ncopies_type = TREE_TYPE (ncopies);
5135 /* Check that NCOPIES is not negative. */
5136 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, ncopies,
5137 build_int_cst (ncopies_type, 0));
5138 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
5139 "Argument NCOPIES of REPEAT intrinsic is negative "
5140 "(its value is %lld)",
5141 fold_convert (long_integer_type_node, ncopies));
5143 /* If the source length is zero, any non negative value of NCOPIES
5144 is valid, and nothing happens. */
5145 n = gfc_create_var (ncopies_type, "ncopies");
5146 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
5147 build_int_cst (size_type_node, 0));
5148 tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
5149 build_int_cst (ncopies_type, 0), ncopies);
5150 gfc_add_modify (&se->pre, n, tmp);
5153 /* Check that ncopies is not too large: ncopies should be less than
5154 (or equal to) MAX / slen, where MAX is the maximal integer of
5155 the gfc_charlen_type_node type. If slen == 0, we need a special
5156 case to avoid the division by zero. */
5157 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5158 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
5159 max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
5160 fold_convert (size_type_node, max), slen);
5161 largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
5162 ? size_type_node : ncopies_type;
5163 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
5164 fold_convert (largest, ncopies),
5165 fold_convert (largest, max));
5166 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
5167 build_int_cst (size_type_node, 0));
5168 cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp,
5169 boolean_false_node, cond);
5170 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
5171 "Argument NCOPIES of REPEAT intrinsic is too large");
5173 /* Compute the destination length. */
5174 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
5175 fold_convert (gfc_charlen_type_node, slen),
5176 fold_convert (gfc_charlen_type_node, ncopies));
5177 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
5178 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
5180 /* Generate the code to do the repeat operation:
5181 for (i = 0; i < ncopies; i++)
5182 memmove (dest + (i * slen * size), src, slen*size); */
5183 gfc_start_block (&block);
5184 count = gfc_create_var (ncopies_type, "count");
5185 gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
5186 exit_label = gfc_build_label_decl (NULL_TREE);
5188 /* Start the loop body. */
5189 gfc_start_block (&body);
5191 /* Exit the loop if count >= ncopies. */
5192 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, count,
5194 tmp = build1_v (GOTO_EXPR, exit_label);
5195 TREE_USED (exit_label) = 1;
5196 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
5197 build_empty_stmt (input_location));
5198 gfc_add_expr_to_block (&body, tmp);
5200 /* Call memmove (dest + (i*slen*size), src, slen*size). */
5201 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
5202 fold_convert (gfc_charlen_type_node, slen),
5203 fold_convert (gfc_charlen_type_node, count));
5204 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
5205 tmp, fold_convert (gfc_charlen_type_node, size));
5206 tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR, pvoid_type_node,
5207 fold_convert (pvoid_type_node, dest),
5208 fold_convert (sizetype, tmp));
5209 tmp = build_call_expr_loc (input_location,
5210 built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
5211 fold_build2_loc (input_location, MULT_EXPR,
5212 size_type_node, slen,
5213 fold_convert (size_type_node,
5215 gfc_add_expr_to_block (&body, tmp);
5217 /* Increment count. */
5218 tmp = fold_build2_loc (input_location, PLUS_EXPR, ncopies_type,
5219 count, build_int_cst (TREE_TYPE (count), 1));
5220 gfc_add_modify (&body, count, tmp);
5222 /* Build the loop. */
5223 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
5224 gfc_add_expr_to_block (&block, tmp);
5226 /* Add the exit label. */
5227 tmp = build1_v (LABEL_EXPR, exit_label);
5228 gfc_add_expr_to_block (&block, tmp);
5230 /* Finish the block. */
5231 tmp = gfc_finish_block (&block);
5232 gfc_add_expr_to_block (&se->pre, tmp);
5234 /* Set the result value. */
5236 se->string_length = dlen;
5240 /* Generate code for the IARGC intrinsic. */
5243 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
5249 /* Call the library function. This always returns an INTEGER(4). */
5250 fndecl = gfor_fndecl_iargc;
5251 tmp = build_call_expr_loc (input_location,
5254 /* Convert it to the required type. */
5255 type = gfc_typenode_for_spec (&expr->ts);
5256 tmp = fold_convert (type, tmp);
5262 /* The loc intrinsic returns the address of its argument as
5263 gfc_index_integer_kind integer. */
5266 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
5272 gcc_assert (!se->ss);
5274 arg_expr = expr->value.function.actual->expr;
5275 ss = gfc_walk_expr (arg_expr);
5276 if (ss == gfc_ss_terminator)
5277 gfc_conv_expr_reference (se, arg_expr);
5279 gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL);
5280 se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
5282 /* Create a temporary variable for loc return value. Without this,
5283 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
5284 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
5285 gfc_add_modify (&se->pre, temp_var, se->expr);
5286 se->expr = temp_var;
5289 /* Generate code for an intrinsic function. Some map directly to library
5290 calls, others get special handling. In some cases the name of the function
5291 used depends on the type specifiers. */
5294 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
5300 name = &expr->value.function.name[2];
5302 if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
5304 lib = gfc_is_intrinsic_libcall (expr);
5308 se->ignore_optional = 1;
5310 switch (expr->value.function.isym->id)
5312 case GFC_ISYM_EOSHIFT:
5314 case GFC_ISYM_RESHAPE:
5315 /* For all of those the first argument specifies the type and the
5316 third is optional. */
5317 conv_generic_with_optional_char_arg (se, expr, 1, 3);
5321 gfc_conv_intrinsic_funcall (se, expr);
5329 switch (expr->value.function.isym->id)
5334 case GFC_ISYM_REPEAT:
5335 gfc_conv_intrinsic_repeat (se, expr);
5339 gfc_conv_intrinsic_trim (se, expr);
5342 case GFC_ISYM_SC_KIND:
5343 gfc_conv_intrinsic_sc_kind (se, expr);
5346 case GFC_ISYM_SI_KIND:
5347 gfc_conv_intrinsic_si_kind (se, expr);
5350 case GFC_ISYM_SR_KIND:
5351 gfc_conv_intrinsic_sr_kind (se, expr);
5354 case GFC_ISYM_EXPONENT:
5355 gfc_conv_intrinsic_exponent (se, expr);
5359 kind = expr->value.function.actual->expr->ts.kind;
5361 fndecl = gfor_fndecl_string_scan;
5363 fndecl = gfor_fndecl_string_scan_char4;
5367 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5370 case GFC_ISYM_VERIFY:
5371 kind = expr->value.function.actual->expr->ts.kind;
5373 fndecl = gfor_fndecl_string_verify;
5375 fndecl = gfor_fndecl_string_verify_char4;
5379 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5382 case GFC_ISYM_ALLOCATED:
5383 gfc_conv_allocated (se, expr);
5386 case GFC_ISYM_ASSOCIATED:
5387 gfc_conv_associated(se, expr);
5390 case GFC_ISYM_SAME_TYPE_AS:
5391 gfc_conv_same_type_as (se, expr);
5395 gfc_conv_intrinsic_abs (se, expr);
5398 case GFC_ISYM_ADJUSTL:
5399 if (expr->ts.kind == 1)
5400 fndecl = gfor_fndecl_adjustl;
5401 else if (expr->ts.kind == 4)
5402 fndecl = gfor_fndecl_adjustl_char4;
5406 gfc_conv_intrinsic_adjust (se, expr, fndecl);
5409 case GFC_ISYM_ADJUSTR:
5410 if (expr->ts.kind == 1)
5411 fndecl = gfor_fndecl_adjustr;
5412 else if (expr->ts.kind == 4)
5413 fndecl = gfor_fndecl_adjustr_char4;
5417 gfc_conv_intrinsic_adjust (se, expr, fndecl);
5420 case GFC_ISYM_AIMAG:
5421 gfc_conv_intrinsic_imagpart (se, expr);
5425 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
5429 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
5432 case GFC_ISYM_ANINT:
5433 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
5437 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
5441 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
5444 case GFC_ISYM_BTEST:
5445 gfc_conv_intrinsic_btest (se, expr);
5448 case GFC_ISYM_ACHAR:
5450 gfc_conv_intrinsic_char (se, expr);
5453 case GFC_ISYM_CONVERSION:
5455 case GFC_ISYM_LOGICAL:
5457 gfc_conv_intrinsic_conversion (se, expr);
5460 /* Integer conversions are handled separately to make sure we get the
5461 correct rounding mode. */
5466 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
5470 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
5473 case GFC_ISYM_CEILING:
5474 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
5477 case GFC_ISYM_FLOOR:
5478 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
5482 gfc_conv_intrinsic_mod (se, expr, 0);
5485 case GFC_ISYM_MODULO:
5486 gfc_conv_intrinsic_mod (se, expr, 1);
5489 case GFC_ISYM_CMPLX:
5490 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
5493 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
5494 gfc_conv_intrinsic_iargc (se, expr);
5497 case GFC_ISYM_COMPLEX:
5498 gfc_conv_intrinsic_cmplx (se, expr, 1);
5501 case GFC_ISYM_CONJG:
5502 gfc_conv_intrinsic_conjg (se, expr);
5505 case GFC_ISYM_COUNT:
5506 gfc_conv_intrinsic_count (se, expr);
5509 case GFC_ISYM_CTIME:
5510 gfc_conv_intrinsic_ctime (se, expr);
5514 gfc_conv_intrinsic_dim (se, expr);
5517 case GFC_ISYM_DOT_PRODUCT:
5518 gfc_conv_intrinsic_dot_product (se, expr);
5521 case GFC_ISYM_DPROD:
5522 gfc_conv_intrinsic_dprod (se, expr);
5525 case GFC_ISYM_FDATE:
5526 gfc_conv_intrinsic_fdate (se, expr);
5529 case GFC_ISYM_FRACTION:
5530 gfc_conv_intrinsic_fraction (se, expr);
5534 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
5537 case GFC_ISYM_IBCLR:
5538 gfc_conv_intrinsic_singlebitop (se, expr, 0);
5541 case GFC_ISYM_IBITS:
5542 gfc_conv_intrinsic_ibits (se, expr);
5545 case GFC_ISYM_IBSET:
5546 gfc_conv_intrinsic_singlebitop (se, expr, 1);
5549 case GFC_ISYM_IACHAR:
5550 case GFC_ISYM_ICHAR:
5551 /* We assume ASCII character sequence. */
5552 gfc_conv_intrinsic_ichar (se, expr);
5555 case GFC_ISYM_IARGC:
5556 gfc_conv_intrinsic_iargc (se, expr);
5560 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
5563 case GFC_ISYM_INDEX:
5564 kind = expr->value.function.actual->expr->ts.kind;
5566 fndecl = gfor_fndecl_string_index;
5568 fndecl = gfor_fndecl_string_index_char4;
5572 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5576 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
5579 case GFC_ISYM_IS_IOSTAT_END:
5580 gfc_conv_has_intvalue (se, expr, LIBERROR_END);
5583 case GFC_ISYM_IS_IOSTAT_EOR:
5584 gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
5587 case GFC_ISYM_ISNAN:
5588 gfc_conv_intrinsic_isnan (se, expr);
5591 case GFC_ISYM_LSHIFT:
5592 gfc_conv_intrinsic_rlshift (se, expr, 0);
5595 case GFC_ISYM_RSHIFT:
5596 gfc_conv_intrinsic_rlshift (se, expr, 1);
5599 case GFC_ISYM_ISHFT:
5600 gfc_conv_intrinsic_ishft (se, expr);
5603 case GFC_ISYM_ISHFTC:
5604 gfc_conv_intrinsic_ishftc (se, expr);
5607 case GFC_ISYM_LEADZ:
5608 gfc_conv_intrinsic_leadz (se, expr);
5611 case GFC_ISYM_TRAILZ:
5612 gfc_conv_intrinsic_trailz (se, expr);
5615 case GFC_ISYM_POPCNT:
5616 gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
5619 case GFC_ISYM_POPPAR:
5620 gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
5623 case GFC_ISYM_LBOUND:
5624 gfc_conv_intrinsic_bound (se, expr, 0);
5627 case GFC_ISYM_TRANSPOSE:
5628 if (se->ss && se->ss->useflags)
5630 gfc_conv_tmp_array_ref (se);
5631 gfc_advance_se_ss_chain (se);
5634 gfc_conv_array_transpose (se, expr->value.function.actual->expr);
5638 gfc_conv_intrinsic_len (se, expr);
5641 case GFC_ISYM_LEN_TRIM:
5642 gfc_conv_intrinsic_len_trim (se, expr);
5646 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
5650 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
5654 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
5658 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
5662 if (expr->ts.type == BT_CHARACTER)
5663 gfc_conv_intrinsic_minmax_char (se, expr, 1);
5665 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
5668 case GFC_ISYM_MAXLOC:
5669 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
5672 case GFC_ISYM_MAXVAL:
5673 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
5676 case GFC_ISYM_MERGE:
5677 gfc_conv_intrinsic_merge (se, expr);
5681 if (expr->ts.type == BT_CHARACTER)
5682 gfc_conv_intrinsic_minmax_char (se, expr, -1);
5684 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
5687 case GFC_ISYM_MINLOC:
5688 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
5691 case GFC_ISYM_MINVAL:
5692 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
5695 case GFC_ISYM_NEAREST:
5696 gfc_conv_intrinsic_nearest (se, expr);
5699 case GFC_ISYM_NORM2:
5700 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
5704 gfc_conv_intrinsic_not (se, expr);
5708 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
5711 case GFC_ISYM_PARITY:
5712 gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
5715 case GFC_ISYM_PRESENT:
5716 gfc_conv_intrinsic_present (se, expr);
5719 case GFC_ISYM_PRODUCT:
5720 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
5723 case GFC_ISYM_RRSPACING:
5724 gfc_conv_intrinsic_rrspacing (se, expr);
5727 case GFC_ISYM_SET_EXPONENT:
5728 gfc_conv_intrinsic_set_exponent (se, expr);
5731 case GFC_ISYM_SCALE:
5732 gfc_conv_intrinsic_scale (se, expr);
5736 gfc_conv_intrinsic_sign (se, expr);
5740 gfc_conv_intrinsic_size (se, expr);
5743 case GFC_ISYM_SIZEOF:
5744 case GFC_ISYM_C_SIZEOF:
5745 gfc_conv_intrinsic_sizeof (se, expr);
5748 case GFC_ISYM_STORAGE_SIZE:
5749 gfc_conv_intrinsic_storage_size (se, expr);
5752 case GFC_ISYM_SPACING:
5753 gfc_conv_intrinsic_spacing (se, expr);
5757 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
5760 case GFC_ISYM_TRANSFER:
5761 if (se->ss && se->ss->useflags)
5763 /* Access the previously obtained result. */
5764 gfc_conv_tmp_array_ref (se);
5765 gfc_advance_se_ss_chain (se);
5768 gfc_conv_intrinsic_transfer (se, expr);
5771 case GFC_ISYM_TTYNAM:
5772 gfc_conv_intrinsic_ttynam (se, expr);
5775 case GFC_ISYM_UBOUND:
5776 gfc_conv_intrinsic_bound (se, expr, 1);
5780 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
5784 gfc_conv_intrinsic_loc (se, expr);
5787 case GFC_ISYM_ACCESS:
5788 case GFC_ISYM_CHDIR:
5789 case GFC_ISYM_CHMOD:
5790 case GFC_ISYM_DTIME:
5791 case GFC_ISYM_ETIME:
5792 case GFC_ISYM_EXTENDS_TYPE_OF:
5794 case GFC_ISYM_FGETC:
5797 case GFC_ISYM_FPUTC:
5798 case GFC_ISYM_FSTAT:
5799 case GFC_ISYM_FTELL:
5800 case GFC_ISYM_GETCWD:
5801 case GFC_ISYM_GETGID:
5802 case GFC_ISYM_GETPID:
5803 case GFC_ISYM_GETUID:
5804 case GFC_ISYM_HOSTNM:
5806 case GFC_ISYM_IERRNO:
5807 case GFC_ISYM_IRAND:
5808 case GFC_ISYM_ISATTY:
5811 case GFC_ISYM_LSTAT:
5812 case GFC_ISYM_MALLOC:
5813 case GFC_ISYM_MATMUL:
5814 case GFC_ISYM_MCLOCK:
5815 case GFC_ISYM_MCLOCK8:
5817 case GFC_ISYM_RENAME:
5818 case GFC_ISYM_SECOND:
5819 case GFC_ISYM_SECNDS:
5820 case GFC_ISYM_SIGNAL:
5822 case GFC_ISYM_SYMLNK:
5823 case GFC_ISYM_SYSTEM:
5825 case GFC_ISYM_TIME8:
5826 case GFC_ISYM_UMASK:
5827 case GFC_ISYM_UNLINK:
5829 gfc_conv_intrinsic_funcall (se, expr);
5832 case GFC_ISYM_EOSHIFT:
5834 case GFC_ISYM_RESHAPE:
5835 /* For those, expr->rank should always be >0 and thus the if above the
5836 switch should have matched. */
5841 gfc_conv_intrinsic_lib_function (se, expr);
5847 /* This generates code to execute before entering the scalarization loop.
5848 Currently does nothing. */
5851 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
5853 switch (ss->expr->value.function.isym->id)
5855 case GFC_ISYM_UBOUND:
5856 case GFC_ISYM_LBOUND:
5865 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
5866 inside the scalarization loop. */
5869 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
5873 /* The two argument version returns a scalar. */
5874 if (expr->value.function.actual->next->expr)
5877 newss = gfc_get_ss ();
5878 newss->type = GFC_SS_INTRINSIC;
5881 newss->data.info.dimen = 1;
5887 /* Walk an intrinsic array libcall. */
5890 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
5894 gcc_assert (expr->rank > 0);
5896 newss = gfc_get_ss ();
5897 newss->type = GFC_SS_FUNCTION;
5900 newss->data.info.dimen = expr->rank;
5906 /* Returns nonzero if the specified intrinsic function call maps directly to
5907 an external library call. Should only be used for functions that return
5911 gfc_is_intrinsic_libcall (gfc_expr * expr)
5913 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
5914 gcc_assert (expr->rank > 0);
5916 switch (expr->value.function.isym->id)
5920 case GFC_ISYM_COUNT:
5922 case GFC_ISYM_MATMUL:
5923 case GFC_ISYM_MAXLOC:
5924 case GFC_ISYM_MAXVAL:
5925 case GFC_ISYM_MINLOC:
5926 case GFC_ISYM_MINVAL:
5927 case GFC_ISYM_NORM2:
5928 case GFC_ISYM_PARITY:
5929 case GFC_ISYM_PRODUCT:
5931 case GFC_ISYM_SHAPE:
5932 case GFC_ISYM_SPREAD:
5933 case GFC_ISYM_TRANSPOSE:
5935 /* Ignore absent optional parameters. */
5938 case GFC_ISYM_RESHAPE:
5939 case GFC_ISYM_CSHIFT:
5940 case GFC_ISYM_EOSHIFT:
5942 case GFC_ISYM_UNPACK:
5943 /* Pass absent optional parameters. */
5951 /* Walk an intrinsic function. */
5953 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
5954 gfc_intrinsic_sym * isym)
5958 if (isym->elemental)
5959 return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
5961 if (expr->rank == 0)
5964 if (gfc_is_intrinsic_libcall (expr))
5965 return gfc_walk_intrinsic_libfunc (ss, expr);
5967 /* Special cases. */
5970 case GFC_ISYM_LBOUND:
5971 case GFC_ISYM_UBOUND:
5972 return gfc_walk_intrinsic_bound (ss, expr);
5974 case GFC_ISYM_TRANSFER:
5975 return gfc_walk_intrinsic_libfunc (ss, expr);
5978 /* This probably meant someone forgot to add an intrinsic to the above
5979 list(s) when they implemented it, or something's gone horribly
5987 gfc_conv_intrinsic_move_alloc (gfc_code *code)
5989 if (code->ext.actual->expr->rank == 0)
5991 /* Scalar arguments: Generate pointer assignments. */
5992 gfc_expr *from, *to;
5996 from = code->ext.actual->expr;
5997 to = code->ext.actual->next->expr;
5999 gfc_start_block (&block);
6001 if (to->ts.type == BT_CLASS)
6002 tmp = gfc_trans_class_assign (to, from, EXEC_POINTER_ASSIGN);
6004 tmp = gfc_trans_pointer_assignment (to, from);
6005 gfc_add_expr_to_block (&block, tmp);
6007 if (from->ts.type == BT_CLASS)
6008 tmp = gfc_trans_class_assign (from, gfc_get_null_expr (NULL),
6009 EXEC_POINTER_ASSIGN);
6011 tmp = gfc_trans_pointer_assignment (from,
6012 gfc_get_null_expr (NULL));
6013 gfc_add_expr_to_block (&block, tmp);
6015 return gfc_finish_block (&block);
6018 /* Array arguments: Generate library code. */
6019 return gfc_trans_call (code, false, NULL_TREE, NULL_TREE, false);
6023 #include "gt-fortran-trans-intrinsic.h"