1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
27 #include "coretypes.h"
28 #include "tm.h" /* For UNITS_PER_WORD. */
31 #include "diagnostic-core.h" /* For internal_error. */
32 #include "toplev.h" /* For rest_of_decl_compilation. */
36 #include "intrinsic.h"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
45 /* This maps fortran intrinsic math functions to external library or GCC
47 typedef struct GTY(()) gfc_intrinsic_map_t {
48 /* The explicit enum is required to work around inadequacies in the
49 garbage collection/gengtype parsing mechanism. */
52 /* Enum value from the "language-independent", aka C-centric, part
53 of gcc, or END_BUILTINS of no such value set. */
54 enum built_in_function float_built_in;
55 enum built_in_function double_built_in;
56 enum built_in_function long_double_built_in;
57 enum built_in_function complex_float_built_in;
58 enum built_in_function complex_double_built_in;
59 enum built_in_function complex_long_double_built_in;
61 /* True if the naming pattern is to prepend "c" for complex and
62 append "f" for kind=4. False if the naming pattern is to
63 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
66 /* True if a complex version of the function exists. */
67 bool complex_available;
69 /* True if the function should be marked const. */
72 /* The base library name of this function. */
75 /* Cache decls created for the various operand types. */
87 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
88 defines complex variants of all of the entries in mathbuiltins.def
90 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
91 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
92 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
93 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
94 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
96 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
97 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
98 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
99 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
100 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
102 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
103 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
104 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
105 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
106 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
108 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
109 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
110 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
111 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
112 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
114 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
116 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
117 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
118 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
119 #include "mathbuiltins.def"
121 /* Functions in libgfortran. */
122 LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
125 LIB_FUNCTION (NONE, NULL, false)
130 #undef DEFINE_MATH_BUILTIN
131 #undef DEFINE_MATH_BUILTIN_C
134 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
137 /* Find the correct variant of a given builtin from its argument. */
139 builtin_decl_for_precision (enum built_in_function base_built_in,
142 enum built_in_function i = END_BUILTINS;
144 gfc_intrinsic_map_t *m;
145 for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
148 if (precision == TYPE_PRECISION (float_type_node))
149 i = m->float_built_in;
150 else if (precision == TYPE_PRECISION (double_type_node))
151 i = m->double_built_in;
152 else if (precision == TYPE_PRECISION (long_double_type_node))
153 i = m->long_double_built_in;
154 else if (precision == TYPE_PRECISION (float128_type_node))
156 /* Special treatment, because it is not exactly a built-in, but
157 a library function. */
158 return m->real16_decl;
161 return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
166 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
169 int i = gfc_validate_kind (BT_REAL, kind, false);
171 if (gfc_real_kinds[i].c_float128)
173 /* For __float128, the story is a bit different, because we return
174 a decl to a library function rather than a built-in. */
175 gfc_intrinsic_map_t *m;
176 for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
179 return m->real16_decl;
182 return builtin_decl_for_precision (double_built_in,
183 gfc_real_kinds[i].mode_precision);
187 /* Evaluate the arguments to an intrinsic function. The value
188 of NARGS may be less than the actual number of arguments in EXPR
189 to allow optional "KIND" arguments that are not included in the
190 generated code to be ignored. */
193 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
194 tree *argarray, int nargs)
196 gfc_actual_arglist *actual;
198 gfc_intrinsic_arg *formal;
202 formal = expr->value.function.isym->formal;
203 actual = expr->value.function.actual;
205 for (curr_arg = 0; curr_arg < nargs; curr_arg++,
206 actual = actual->next,
207 formal = formal ? formal->next : NULL)
211 /* Skip omitted optional arguments. */
218 /* Evaluate the parameter. This will substitute scalarized
219 references automatically. */
220 gfc_init_se (&argse, se);
222 if (e->ts.type == BT_CHARACTER)
224 gfc_conv_expr (&argse, e);
225 gfc_conv_string_parameter (&argse);
226 argarray[curr_arg++] = argse.string_length;
227 gcc_assert (curr_arg < nargs);
230 gfc_conv_expr_val (&argse, e);
232 /* If an optional argument is itself an optional dummy argument,
233 check its presence and substitute a null if absent. */
234 if (e->expr_type == EXPR_VARIABLE
235 && e->symtree->n.sym->attr.optional
238 gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
240 gfc_add_block_to_block (&se->pre, &argse.pre);
241 gfc_add_block_to_block (&se->post, &argse.post);
242 argarray[curr_arg] = argse.expr;
246 /* Count the number of actual arguments to the intrinsic function EXPR
247 including any "hidden" string length arguments. */
250 gfc_intrinsic_argument_list_length (gfc_expr *expr)
253 gfc_actual_arglist *actual;
255 for (actual = expr->value.function.actual; actual; actual = actual->next)
260 if (actual->expr->ts.type == BT_CHARACTER)
270 /* Conversions between different types are output by the frontend as
271 intrinsic functions. We implement these directly with inline code. */
274 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
280 nargs = gfc_intrinsic_argument_list_length (expr);
281 args = XALLOCAVEC (tree, nargs);
283 /* Evaluate all the arguments passed. Whilst we're only interested in the
284 first one here, there are other parts of the front-end that assume this
285 and will trigger an ICE if it's not the case. */
286 type = gfc_typenode_for_spec (&expr->ts);
287 gcc_assert (expr->value.function.actual->expr);
288 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
290 /* Conversion between character kinds involves a call to a library
292 if (expr->ts.type == BT_CHARACTER)
294 tree fndecl, var, addr, tmp;
296 if (expr->ts.kind == 1
297 && expr->value.function.actual->expr->ts.kind == 4)
298 fndecl = gfor_fndecl_convert_char4_to_char1;
299 else if (expr->ts.kind == 4
300 && expr->value.function.actual->expr->ts.kind == 1)
301 fndecl = gfor_fndecl_convert_char1_to_char4;
305 /* Create the variable storing the converted value. */
306 type = gfc_get_pchar_type (expr->ts.kind);
307 var = gfc_create_var (type, "str");
308 addr = gfc_build_addr_expr (build_pointer_type (type), var);
310 /* Call the library function that will perform the conversion. */
311 gcc_assert (nargs >= 2);
312 tmp = build_call_expr_loc (input_location,
313 fndecl, 3, addr, args[0], args[1]);
314 gfc_add_expr_to_block (&se->pre, tmp);
316 /* Free the temporary afterwards. */
317 tmp = gfc_call_free (var);
318 gfc_add_expr_to_block (&se->post, tmp);
321 se->string_length = args[0];
326 /* Conversion from complex to non-complex involves taking the real
327 component of the value. */
328 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
329 && expr->ts.type != BT_COMPLEX)
333 artype = TREE_TYPE (TREE_TYPE (args[0]));
334 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
338 se->expr = convert (type, args[0]);
341 /* This is needed because the gcc backend only implements
342 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
343 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
344 Similarly for CEILING. */
347 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
354 argtype = TREE_TYPE (arg);
355 arg = gfc_evaluate_now (arg, pblock);
357 intval = convert (type, arg);
358 intval = gfc_evaluate_now (intval, pblock);
360 tmp = convert (argtype, intval);
361 cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
362 boolean_type_node, tmp, arg);
364 tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
365 intval, build_int_cst (type, 1));
366 tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
371 /* Round to nearest integer, away from zero. */
374 build_round_expr (tree arg, tree restype)
379 int argprec, resprec;
381 argtype = TREE_TYPE (arg);
382 argprec = TYPE_PRECISION (argtype);
383 resprec = TYPE_PRECISION (restype);
385 /* Depending on the type of the result, choose the long int intrinsic
386 (lround family) or long long intrinsic (llround). We might also
387 need to convert the result afterwards. */
388 if (resprec <= LONG_TYPE_SIZE)
390 else if (resprec <= LONG_LONG_TYPE_SIZE)
395 /* Now, depending on the argument type, we choose between intrinsics. */
397 fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
399 fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
401 return fold_convert (restype, build_call_expr_loc (input_location,
406 /* Convert a real to an integer using a specific rounding mode.
407 Ideally we would just build the corresponding GENERIC node,
408 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
411 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
412 enum rounding_mode op)
417 return build_fixbound_expr (pblock, arg, type, 0);
421 return build_fixbound_expr (pblock, arg, type, 1);
425 return build_round_expr (arg, type);
429 return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
438 /* Round a real value using the specified rounding mode.
439 We use a temporary integer of that same kind size as the result.
440 Values larger than those that can be represented by this kind are
441 unchanged, as they will not be accurate enough to represent the
443 huge = HUGE (KIND (a))
444 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
448 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
460 kind = expr->ts.kind;
461 nargs = gfc_intrinsic_argument_list_length (expr);
464 /* We have builtin functions for some cases. */
468 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
472 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
479 /* Evaluate the argument. */
480 gcc_assert (expr->value.function.actual->expr);
481 gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
483 /* Use a builtin function if one exists. */
484 if (decl != NULL_TREE)
486 se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
490 /* This code is probably redundant, but we'll keep it lying around just
492 type = gfc_typenode_for_spec (&expr->ts);
493 arg[0] = gfc_evaluate_now (arg[0], &se->pre);
495 /* Test if the value is too large to handle sensibly. */
496 gfc_set_model_kind (kind);
498 n = gfc_validate_kind (BT_INTEGER, kind, false);
499 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
500 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
501 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, arg[0],
504 mpfr_neg (huge, huge, GFC_RND_MODE);
505 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
506 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, arg[0],
508 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
510 itype = gfc_get_int_type (kind);
512 tmp = build_fix_expr (&se->pre, arg[0], itype, op);
513 tmp = convert (type, tmp);
514 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
520 /* Convert to an integer using the specified rounding mode. */
523 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
529 nargs = gfc_intrinsic_argument_list_length (expr);
530 args = XALLOCAVEC (tree, nargs);
532 /* Evaluate the argument, we process all arguments even though we only
533 use the first one for code generation purposes. */
534 type = gfc_typenode_for_spec (&expr->ts);
535 gcc_assert (expr->value.function.actual->expr);
536 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
538 if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
540 /* Conversion to a different integer kind. */
541 se->expr = convert (type, args[0]);
545 /* Conversion from complex to non-complex involves taking the real
546 component of the value. */
547 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
548 && expr->ts.type != BT_COMPLEX)
552 artype = TREE_TYPE (TREE_TYPE (args[0]));
553 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
557 se->expr = build_fix_expr (&se->pre, args[0], type, op);
562 /* Get the imaginary component of a value. */
565 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
569 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
570 se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
571 TREE_TYPE (TREE_TYPE (arg)), arg);
575 /* Get the complex conjugate of a value. */
578 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
582 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
583 se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
589 define_quad_builtin (const char *name, tree type, bool is_const)
592 fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
595 /* Mark the decl as external. */
596 DECL_EXTERNAL (fndecl) = 1;
597 TREE_PUBLIC (fndecl) = 1;
599 /* Mark it __attribute__((const)). */
600 TREE_READONLY (fndecl) = is_const;
602 rest_of_decl_compilation (fndecl, 1, 0);
609 /* Initialize function decls for library functions. The external functions
610 are created as required. Builtin functions are added here. */
613 gfc_build_intrinsic_lib_fndecls (void)
615 gfc_intrinsic_map_t *m;
616 tree quad_decls[END_BUILTINS + 1];
618 if (gfc_real16_is_float128)
620 /* If we have soft-float types, we create the decls for their
621 C99-like library functions. For now, we only handle __float128
622 q-suffixed functions. */
624 tree type, complex_type, func_1, func_2, func_cabs, func_frexp;
625 tree func_lround, func_llround, func_scalbn, func_cpow;
627 memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
629 type = float128_type_node;
630 complex_type = complex_float128_type_node;
631 /* type (*) (type) */
632 func_1 = build_function_type_list (type, type, NULL_TREE);
633 /* long (*) (type) */
634 func_lround = build_function_type_list (long_integer_type_node,
636 /* long long (*) (type) */
637 func_llround = build_function_type_list (long_long_integer_type_node,
639 /* type (*) (type, type) */
640 func_2 = build_function_type_list (type, type, type, NULL_TREE);
641 /* type (*) (type, &int) */
643 = build_function_type_list (type,
645 build_pointer_type (integer_type_node),
647 /* type (*) (type, int) */
648 func_scalbn = build_function_type_list (type,
649 type, integer_type_node, NULL_TREE);
650 /* type (*) (complex type) */
651 func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
652 /* complex type (*) (complex type, complex type) */
654 = build_function_type_list (complex_type,
655 complex_type, complex_type, NULL_TREE);
657 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
658 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
659 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
661 /* Only these built-ins are actually needed here. These are used directly
662 from the code, when calling builtin_decl_for_precision() or
663 builtin_decl_for_float_type(). The others are all constructed by
664 gfc_get_intrinsic_lib_fndecl(). */
665 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
666 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
668 #include "mathbuiltins.def"
672 #undef DEFINE_MATH_BUILTIN
673 #undef DEFINE_MATH_BUILTIN_C
677 /* Add GCC builtin functions. */
678 for (m = gfc_intrinsic_map;
679 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
681 if (m->float_built_in != END_BUILTINS)
682 m->real4_decl = builtin_decl_explicit (m->float_built_in);
683 if (m->complex_float_built_in != END_BUILTINS)
684 m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
685 if (m->double_built_in != END_BUILTINS)
686 m->real8_decl = builtin_decl_explicit (m->double_built_in);
687 if (m->complex_double_built_in != END_BUILTINS)
688 m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
690 /* If real(kind=10) exists, it is always long double. */
691 if (m->long_double_built_in != END_BUILTINS)
692 m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
693 if (m->complex_long_double_built_in != END_BUILTINS)
695 = builtin_decl_explicit (m->complex_long_double_built_in);
697 if (!gfc_real16_is_float128)
699 if (m->long_double_built_in != END_BUILTINS)
700 m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
701 if (m->complex_long_double_built_in != END_BUILTINS)
703 = builtin_decl_explicit (m->complex_long_double_built_in);
705 else if (quad_decls[m->double_built_in] != NULL_TREE)
707 /* Quad-precision function calls are constructed when first
708 needed by builtin_decl_for_precision(), except for those
709 that will be used directly (define by OTHER_BUILTIN). */
710 m->real16_decl = quad_decls[m->double_built_in];
712 else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
714 /* Same thing for the complex ones. */
715 m->complex16_decl = quad_decls[m->double_built_in];
721 /* Create a fndecl for a simple intrinsic library function. */
724 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
727 VEC(tree,gc) *argtypes;
729 gfc_actual_arglist *actual;
732 char name[GFC_MAX_SYMBOL_LEN + 3];
735 if (ts->type == BT_REAL)
740 pdecl = &m->real4_decl;
743 pdecl = &m->real8_decl;
746 pdecl = &m->real10_decl;
749 pdecl = &m->real16_decl;
755 else if (ts->type == BT_COMPLEX)
757 gcc_assert (m->complex_available);
762 pdecl = &m->complex4_decl;
765 pdecl = &m->complex8_decl;
768 pdecl = &m->complex10_decl;
771 pdecl = &m->complex16_decl;
785 int n = gfc_validate_kind (BT_REAL, ts->kind, false);
786 if (gfc_real_kinds[n].c_float)
787 snprintf (name, sizeof (name), "%s%s%s",
788 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
789 else if (gfc_real_kinds[n].c_double)
790 snprintf (name, sizeof (name), "%s%s",
791 ts->type == BT_COMPLEX ? "c" : "", m->name);
792 else if (gfc_real_kinds[n].c_long_double)
793 snprintf (name, sizeof (name), "%s%s%s",
794 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
795 else if (gfc_real_kinds[n].c_float128)
796 snprintf (name, sizeof (name), "%s%s%s",
797 ts->type == BT_COMPLEX ? "c" : "", m->name, "q");
803 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
804 ts->type == BT_COMPLEX ? 'c' : 'r',
809 for (actual = expr->value.function.actual; actual; actual = actual->next)
811 type = gfc_typenode_for_spec (&actual->expr->ts);
812 VEC_safe_push (tree, gc, argtypes, type);
814 type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
815 fndecl = build_decl (input_location,
816 FUNCTION_DECL, get_identifier (name), type);
818 /* Mark the decl as external. */
819 DECL_EXTERNAL (fndecl) = 1;
820 TREE_PUBLIC (fndecl) = 1;
822 /* Mark it __attribute__((const)), if possible. */
823 TREE_READONLY (fndecl) = m->is_constant;
825 rest_of_decl_compilation (fndecl, 1, 0);
832 /* Convert an intrinsic function into an external or builtin call. */
835 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
837 gfc_intrinsic_map_t *m;
841 unsigned int num_args;
844 id = expr->value.function.isym->id;
845 /* Find the entry for this function. */
846 for (m = gfc_intrinsic_map;
847 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
853 if (m->id == GFC_ISYM_NONE)
855 internal_error ("Intrinsic function %s(%d) not recognized",
856 expr->value.function.name, id);
859 /* Get the decl and generate the call. */
860 num_args = gfc_intrinsic_argument_list_length (expr);
861 args = XALLOCAVEC (tree, num_args);
863 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
864 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
865 rettype = TREE_TYPE (TREE_TYPE (fndecl));
867 fndecl = build_addr (fndecl, current_function_decl);
868 se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
872 /* If bounds-checking is enabled, create code to verify at runtime that the
873 string lengths for both expressions are the same (needed for e.g. MERGE).
874 If bounds-checking is not enabled, does nothing. */
877 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
878 tree a, tree b, stmtblock_t* target)
883 /* If bounds-checking is disabled, do nothing. */
884 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
887 /* Compare the two string lengths. */
888 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, a, b);
890 /* Output the runtime-check. */
891 name = gfc_build_cstring_const (intr_name);
892 name = gfc_build_addr_expr (pchar_type_node, name);
893 gfc_trans_runtime_check (true, false, cond, target, where,
894 "Unequal character lengths (%ld/%ld) in %s",
895 fold_convert (long_integer_type_node, a),
896 fold_convert (long_integer_type_node, b), name);
900 /* The EXPONENT(s) intrinsic function is translated into
907 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
909 tree arg, type, res, tmp, frexp;
911 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
912 expr->value.function.actual->expr->ts.kind);
914 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
916 res = gfc_create_var (integer_type_node, NULL);
917 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
918 gfc_build_addr_expr (NULL_TREE, res));
919 gfc_add_expr_to_block (&se->pre, tmp);
921 type = gfc_typenode_for_spec (&expr->ts);
922 se->expr = fold_convert (type, res);
926 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
927 AR_FULL, suitable for the scalarizer. */
930 walk_coarray (gfc_expr *e)
934 gcc_assert (gfc_get_corank (e) > 0);
936 ss = gfc_walk_expr (e);
938 /* Fix scalar coarray. */
939 if (ss == gfc_ss_terminator)
946 if (ref->type == REF_ARRAY
947 && ref->u.ar.codimen > 0)
953 gcc_assert (ref != NULL);
954 if (ref->u.ar.type == AR_ELEMENT)
955 ref->u.ar.type = AR_SECTION;
956 ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
964 trans_this_image (gfc_se * se, gfc_expr *expr)
967 tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
968 lbound, ubound, extent, ml;
973 /* The case -fcoarray=single is handled elsewhere. */
974 gcc_assert (gfc_option.coarray != GFC_FCOARRAY_SINGLE);
976 gfc_init_coarray_decl (false);
978 /* Argument-free version: THIS_IMAGE(). */
979 if (expr->value.function.actual->expr == NULL)
981 se->expr = gfort_gvar_caf_this_image;
985 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
987 type = gfc_get_int_type (gfc_default_integer_kind);
988 corank = gfc_get_corank (expr->value.function.actual->expr);
989 rank = expr->value.function.actual->expr->rank;
991 /* Obtain the descriptor of the COARRAY. */
992 gfc_init_se (&argse, NULL);
993 ss = walk_coarray (expr->value.function.actual->expr);
994 gcc_assert (ss != gfc_ss_terminator);
995 argse.want_coarray = 1;
996 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
997 gfc_add_block_to_block (&se->pre, &argse.pre);
998 gfc_add_block_to_block (&se->post, &argse.post);
1003 /* Create an implicit second parameter from the loop variable. */
1004 gcc_assert (!expr->value.function.actual->next->expr);
1005 gcc_assert (corank > 0);
1006 gcc_assert (se->loop->dimen == 1);
1007 gcc_assert (se->ss->expr == expr);
1009 dim_arg = se->loop->loopvar[0];
1010 dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
1011 gfc_array_index_type, dim_arg,
1012 build_int_cst (TREE_TYPE (dim_arg), 1));
1013 gfc_advance_se_ss_chain (se);
1017 /* Use the passed DIM= argument. */
1018 gcc_assert (expr->value.function.actual->next->expr);
1019 gfc_init_se (&argse, NULL);
1020 gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
1021 gfc_array_index_type);
1022 gfc_add_block_to_block (&se->pre, &argse.pre);
1023 dim_arg = argse.expr;
1025 if (INTEGER_CST_P (dim_arg))
1029 hi = TREE_INT_CST_HIGH (dim_arg);
1030 co_dim = TREE_INT_CST_LOW (dim_arg);
1031 if (hi || co_dim < 1
1032 || co_dim > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
1033 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1034 "dimension index", expr->value.function.isym->name,
1037 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1039 dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
1040 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1042 build_int_cst (TREE_TYPE (dim_arg), 1));
1043 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
1044 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1046 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1047 boolean_type_node, cond, tmp);
1048 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1053 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1054 one always has a dim_arg argument.
1056 m = this_images() - 1
1058 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1061 extent = gfc_extent(i)
1069 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1070 : m + lcobound(corank)
1073 m = gfc_create_var (type, NULL);
1074 ml = gfc_create_var (type, NULL);
1075 loop_var = gfc_create_var (integer_type_node, NULL);
1076 min_var = gfc_create_var (integer_type_node, NULL);
1078 /* m = this_image () - 1. */
1079 tmp = fold_convert (type, gfort_gvar_caf_this_image);
1080 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, tmp,
1081 build_int_cst (type, 1));
1082 gfc_add_modify (&se->pre, m, tmp);
1084 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1085 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
1086 fold_convert (integer_type_node, dim_arg),
1087 build_int_cst (integer_type_node, rank - 1));
1088 tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
1089 build_int_cst (integer_type_node, rank + corank - 2),
1091 gfc_add_modify (&se->pre, min_var, tmp);
1094 tmp = build_int_cst (integer_type_node, rank);
1095 gfc_add_modify (&se->pre, loop_var, tmp);
1097 exit_label = gfc_build_label_decl (NULL_TREE);
1098 TREE_USED (exit_label) = 1;
1101 gfc_init_block (&loop);
1104 gfc_add_modify (&loop, ml, m);
1107 lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
1108 ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
1109 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1110 extent = fold_convert (type, extent);
1113 gfc_add_modify (&loop, m,
1114 fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
1117 /* Exit condition: if (i >= min_var) goto exit_label. */
1118 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, loop_var,
1120 tmp = build1_v (GOTO_EXPR, exit_label);
1121 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
1122 build_empty_stmt (input_location));
1123 gfc_add_expr_to_block (&loop, tmp);
1125 /* Increment loop variable: i++. */
1126 gfc_add_modify (&loop, loop_var,
1127 fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
1129 build_int_cst (integer_type_node, 1)));
1131 /* Making the loop... actually loop! */
1132 tmp = gfc_finish_block (&loop);
1133 tmp = build1_v (LOOP_EXPR, tmp);
1134 gfc_add_expr_to_block (&se->pre, tmp);
1136 /* The exit label. */
1137 tmp = build1_v (LABEL_EXPR, exit_label);
1138 gfc_add_expr_to_block (&se->pre, tmp);
1140 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1141 : m + lcobound(corank) */
1143 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, dim_arg,
1144 build_int_cst (TREE_TYPE (dim_arg), corank));
1146 lbound = gfc_conv_descriptor_lbound_get (desc,
1147 fold_build2_loc (input_location, PLUS_EXPR,
1148 gfc_array_index_type, dim_arg,
1149 build_int_cst (TREE_TYPE (dim_arg), rank-1)));
1150 lbound = fold_convert (type, lbound);
1152 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
1153 fold_build2_loc (input_location, MULT_EXPR, type,
1155 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
1157 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
1158 fold_build2_loc (input_location, PLUS_EXPR, type,
1164 trans_image_index (gfc_se * se, gfc_expr *expr)
1166 tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
1168 gfc_se argse, subse;
1170 int rank, corank, codim;
1172 type = gfc_get_int_type (gfc_default_integer_kind);
1173 corank = gfc_get_corank (expr->value.function.actual->expr);
1174 rank = expr->value.function.actual->expr->rank;
1176 /* Obtain the descriptor of the COARRAY. */
1177 gfc_init_se (&argse, NULL);
1178 ss = walk_coarray (expr->value.function.actual->expr);
1179 gcc_assert (ss != gfc_ss_terminator);
1180 argse.want_coarray = 1;
1181 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
1182 gfc_add_block_to_block (&se->pre, &argse.pre);
1183 gfc_add_block_to_block (&se->post, &argse.post);
1186 /* Obtain a handle to the SUB argument. */
1187 gfc_init_se (&subse, NULL);
1188 subss = gfc_walk_expr (expr->value.function.actual->next->expr);
1189 gcc_assert (subss != gfc_ss_terminator);
1190 gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr,
1192 gfc_add_block_to_block (&se->pre, &subse.pre);
1193 gfc_add_block_to_block (&se->post, &subse.post);
1194 subdesc = build_fold_indirect_ref_loc (input_location,
1195 gfc_conv_descriptor_data_get (subse.expr));
1197 /* Fortran 2008 does not require that the values remain in the cobounds,
1198 thus we need explicitly check this - and return 0 if they are exceeded. */
1200 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
1201 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
1202 invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1203 fold_convert (gfc_array_index_type, tmp),
1206 for (codim = corank + rank - 2; codim >= rank; codim--)
1208 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1209 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
1210 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
1211 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1212 fold_convert (gfc_array_index_type, tmp),
1214 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1215 boolean_type_node, invalid_bound, cond);
1216 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1217 fold_convert (gfc_array_index_type, tmp),
1219 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1220 boolean_type_node, invalid_bound, cond);
1223 invalid_bound = gfc_unlikely (invalid_bound);
1226 /* See Fortran 2008, C.10 for the following algorithm. */
1228 /* coindex = sub(corank) - lcobound(n). */
1229 coindex = fold_convert (gfc_array_index_type,
1230 gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
1232 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
1233 coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
1234 fold_convert (gfc_array_index_type, coindex),
1237 for (codim = corank + rank - 2; codim >= rank; codim--)
1239 tree extent, ubound;
1241 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1242 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1243 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
1244 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1246 /* coindex *= extent. */
1247 coindex = fold_build2_loc (input_location, MULT_EXPR,
1248 gfc_array_index_type, coindex, extent);
1250 /* coindex += sub(codim). */
1251 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
1252 coindex = fold_build2_loc (input_location, PLUS_EXPR,
1253 gfc_array_index_type, coindex,
1254 fold_convert (gfc_array_index_type, tmp));
1256 /* coindex -= lbound(codim). */
1257 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1258 coindex = fold_build2_loc (input_location, MINUS_EXPR,
1259 gfc_array_index_type, coindex, lbound);
1262 coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
1263 fold_convert(type, coindex),
1264 build_int_cst (type, 1));
1266 /* Return 0 if "coindex" exceeds num_images(). */
1268 if (gfc_option.coarray == GFC_FCOARRAY_SINGLE)
1269 num_images = build_int_cst (type, 1);
1272 gfc_init_coarray_decl (false);
1273 num_images = gfort_gvar_caf_num_images;
1276 tmp = gfc_create_var (type, NULL);
1277 gfc_add_modify (&se->pre, tmp, coindex);
1279 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
1281 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
1283 fold_convert (boolean_type_node, invalid_bound));
1284 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
1285 build_int_cst (type, 0), tmp);
1290 trans_num_images (gfc_se * se)
1292 gfc_init_coarray_decl (false);
1293 se->expr = gfort_gvar_caf_num_images;
1297 /* Evaluate a single upper or lower bound. */
1298 /* TODO: bound intrinsic generates way too much unnecessary code. */
1301 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
1303 gfc_actual_arglist *arg;
1304 gfc_actual_arglist *arg2;
1309 tree cond, cond1, cond3, cond4, size;
1314 gfc_array_spec * as;
1316 arg = expr->value.function.actual;
1321 /* Create an implicit second parameter from the loop variable. */
1322 gcc_assert (!arg2->expr);
1323 gcc_assert (se->loop->dimen == 1);
1324 gcc_assert (se->ss->expr == expr);
1325 gfc_advance_se_ss_chain (se);
1326 bound = se->loop->loopvar[0];
1327 bound = fold_build2_loc (input_location, MINUS_EXPR,
1328 gfc_array_index_type, bound,
1333 /* use the passed argument. */
1334 gcc_assert (arg2->expr);
1335 gfc_init_se (&argse, NULL);
1336 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
1337 gfc_add_block_to_block (&se->pre, &argse.pre);
1339 /* Convert from one based to zero based. */
1340 bound = fold_build2_loc (input_location, MINUS_EXPR,
1341 gfc_array_index_type, bound,
1342 gfc_index_one_node);
1345 /* TODO: don't re-evaluate the descriptor on each iteration. */
1346 /* Get a descriptor for the first parameter. */
1347 ss = gfc_walk_expr (arg->expr);
1348 gcc_assert (ss != gfc_ss_terminator);
1349 gfc_init_se (&argse, NULL);
1350 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
1351 gfc_add_block_to_block (&se->pre, &argse.pre);
1352 gfc_add_block_to_block (&se->post, &argse.post);
1356 if (INTEGER_CST_P (bound))
1360 hi = TREE_INT_CST_HIGH (bound);
1361 low = TREE_INT_CST_LOW (bound);
1362 if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
1363 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1364 "dimension index", upper ? "UBOUND" : "LBOUND",
1369 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1371 bound = gfc_evaluate_now (bound, &se->pre);
1372 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1373 bound, build_int_cst (TREE_TYPE (bound), 0));
1374 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
1375 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1377 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1378 boolean_type_node, cond, tmp);
1379 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1384 ubound = gfc_conv_descriptor_ubound_get (desc, bound);
1385 lbound = gfc_conv_descriptor_lbound_get (desc, bound);
1387 as = gfc_get_full_arrayspec_from_expr (arg->expr);
1389 /* 13.14.53: Result value for LBOUND
1391 Case (i): For an array section or for an array expression other than a
1392 whole array or array structure component, LBOUND(ARRAY, DIM)
1393 has the value 1. For a whole array or array structure
1394 component, LBOUND(ARRAY, DIM) has the value:
1395 (a) equal to the lower bound for subscript DIM of ARRAY if
1396 dimension DIM of ARRAY does not have extent zero
1397 or if ARRAY is an assumed-size array of rank DIM,
1400 13.14.113: Result value for UBOUND
1402 Case (i): For an array section or for an array expression other than a
1403 whole array or array structure component, UBOUND(ARRAY, DIM)
1404 has the value equal to the number of elements in the given
1405 dimension; otherwise, it has a value equal to the upper bound
1406 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1407 not have size zero and has value zero if dimension DIM has
1412 tree stride = gfc_conv_descriptor_stride_get (desc, bound);
1414 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1416 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1417 stride, gfc_index_zero_node);
1418 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1419 boolean_type_node, cond3, cond1);
1420 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1421 stride, gfc_index_zero_node);
1426 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1427 boolean_type_node, cond3, cond4);
1428 cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1429 gfc_index_one_node, lbound);
1430 cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1431 boolean_type_node, cond4, cond5);
1433 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1434 boolean_type_node, cond, cond5);
1436 se->expr = fold_build3_loc (input_location, COND_EXPR,
1437 gfc_array_index_type, cond,
1438 ubound, gfc_index_zero_node);
1442 if (as->type == AS_ASSUMED_SIZE)
1443 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1444 bound, build_int_cst (TREE_TYPE (bound),
1445 arg->expr->rank - 1));
1447 cond = boolean_false_node;
1449 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1450 boolean_type_node, cond3, cond4);
1451 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1452 boolean_type_node, cond, cond1);
1454 se->expr = fold_build3_loc (input_location, COND_EXPR,
1455 gfc_array_index_type, cond,
1456 lbound, gfc_index_one_node);
1463 size = fold_build2_loc (input_location, MINUS_EXPR,
1464 gfc_array_index_type, ubound, lbound);
1465 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
1466 gfc_array_index_type, size,
1467 gfc_index_one_node);
1468 se->expr = fold_build2_loc (input_location, MAX_EXPR,
1469 gfc_array_index_type, se->expr,
1470 gfc_index_zero_node);
1473 se->expr = gfc_index_one_node;
1476 type = gfc_typenode_for_spec (&expr->ts);
1477 se->expr = convert (type, se->expr);
1482 conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
1484 gfc_actual_arglist *arg;
1485 gfc_actual_arglist *arg2;
1488 tree bound, resbound, resbound2, desc, cond, tmp;
1492 gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
1493 || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
1494 || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
1496 arg = expr->value.function.actual;
1499 gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
1500 corank = gfc_get_corank (arg->expr);
1502 ss = walk_coarray (arg->expr);
1503 gcc_assert (ss != gfc_ss_terminator);
1504 gfc_init_se (&argse, NULL);
1505 argse.want_coarray = 1;
1507 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
1508 gfc_add_block_to_block (&se->pre, &argse.pre);
1509 gfc_add_block_to_block (&se->post, &argse.post);
1514 /* Create an implicit second parameter from the loop variable. */
1515 gcc_assert (!arg2->expr);
1516 gcc_assert (corank > 0);
1517 gcc_assert (se->loop->dimen == 1);
1518 gcc_assert (se->ss->expr == expr);
1520 bound = se->loop->loopvar[0];
1521 bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1522 bound, gfc_rank_cst[arg->expr->rank]);
1523 gfc_advance_se_ss_chain (se);
1527 /* use the passed argument. */
1528 gcc_assert (arg2->expr);
1529 gfc_init_se (&argse, NULL);
1530 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
1531 gfc_add_block_to_block (&se->pre, &argse.pre);
1534 if (INTEGER_CST_P (bound))
1538 hi = TREE_INT_CST_HIGH (bound);
1539 low = TREE_INT_CST_LOW (bound);
1540 if (hi || low < 1 || low > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
1541 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1542 "dimension index", expr->value.function.isym->name,
1545 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1547 bound = gfc_evaluate_now (bound, &se->pre);
1548 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1549 bound, build_int_cst (TREE_TYPE (bound), 1));
1550 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
1551 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1553 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1554 boolean_type_node, cond, tmp);
1555 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1560 /* Substract 1 to get to zero based and add dimensions. */
1561 switch (arg->expr->rank)
1564 bound = fold_build2_loc (input_location, MINUS_EXPR,
1565 gfc_array_index_type, bound,
1566 gfc_index_one_node);
1570 bound = fold_build2_loc (input_location, PLUS_EXPR,
1571 gfc_array_index_type, bound,
1572 gfc_rank_cst[arg->expr->rank - 1]);
1576 resbound = gfc_conv_descriptor_lbound_get (desc, bound);
1578 /* Handle UCOBOUND with special handling of the last codimension. */
1579 if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
1581 /* Last codimension: For -fcoarray=single just return
1582 the lcobound - otherwise add
1583 ceiling (real (num_images ()) / real (size)) - 1
1584 = (num_images () + size - 1) / size - 1
1585 = (num_images - 1) / size(),
1586 where size is the product of the extent of all but the last
1589 if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && corank > 1)
1593 gfc_init_coarray_decl (false);
1594 cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
1596 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1597 gfc_array_index_type,
1598 gfort_gvar_caf_num_images,
1599 build_int_cst (gfc_array_index_type, 1));
1600 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1601 gfc_array_index_type, tmp,
1602 fold_convert (gfc_array_index_type, cosize));
1603 resbound = fold_build2_loc (input_location, PLUS_EXPR,
1604 gfc_array_index_type, resbound, tmp);
1606 else if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
1608 /* ubound = lbound + num_images() - 1. */
1609 gfc_init_coarray_decl (false);
1610 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1611 gfc_array_index_type,
1612 gfort_gvar_caf_num_images,
1613 build_int_cst (gfc_array_index_type, 1));
1614 resbound = fold_build2_loc (input_location, PLUS_EXPR,
1615 gfc_array_index_type, resbound, tmp);
1620 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1622 build_int_cst (TREE_TYPE (bound),
1623 arg->expr->rank + corank - 1));
1625 resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
1626 se->expr = fold_build3_loc (input_location, COND_EXPR,
1627 gfc_array_index_type, cond,
1628 resbound, resbound2);
1631 se->expr = resbound;
1634 se->expr = resbound;
1636 type = gfc_typenode_for_spec (&expr->ts);
1637 se->expr = convert (type, se->expr);
1642 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
1646 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1648 switch (expr->value.function.actual->expr->ts.type)
1652 se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
1657 cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
1658 se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
1667 /* Create a complex value from one or two real components. */
1670 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1676 unsigned int num_args;
1678 num_args = gfc_intrinsic_argument_list_length (expr);
1679 args = XALLOCAVEC (tree, num_args);
1681 type = gfc_typenode_for_spec (&expr->ts);
1682 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1683 real = convert (TREE_TYPE (type), args[0]);
1685 imag = convert (TREE_TYPE (type), args[1]);
1686 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1688 imag = fold_build1_loc (input_location, IMAGPART_EXPR,
1689 TREE_TYPE (TREE_TYPE (args[0])), args[0]);
1690 imag = convert (TREE_TYPE (type), imag);
1693 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1695 se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
1698 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1699 MODULO(A, P) = A - FLOOR (A / P) * P */
1700 /* TODO: MOD(x, 0) */
1703 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1715 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1717 switch (expr->ts.type)
1720 /* Integer case is easy, we've got a builtin op. */
1721 type = TREE_TYPE (args[0]);
1724 se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
1727 se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
1733 /* Check if we have a builtin fmod. */
1734 fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
1736 /* Use it if it exists. */
1737 if (fmod != NULL_TREE)
1739 tmp = build_addr (fmod, current_function_decl);
1740 se->expr = build_call_array_loc (input_location,
1741 TREE_TYPE (TREE_TYPE (fmod)),
1747 type = TREE_TYPE (args[0]);
1749 args[0] = gfc_evaluate_now (args[0], &se->pre);
1750 args[1] = gfc_evaluate_now (args[1], &se->pre);
1753 modulo = arg - floor (arg/arg2) * arg2, so
1754 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1756 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1757 thereby avoiding another division and retaining the accuracy
1758 of the builtin function. */
1759 if (fmod != NULL_TREE && modulo)
1761 tree zero = gfc_build_const (type, integer_zero_node);
1762 tmp = gfc_evaluate_now (se->expr, &se->pre);
1763 test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1765 test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1767 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
1768 boolean_type_node, test, test2);
1769 test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1771 test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1772 boolean_type_node, test, test2);
1773 test = gfc_evaluate_now (test, &se->pre);
1774 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
1775 fold_build2_loc (input_location, PLUS_EXPR,
1776 type, tmp, args[1]), tmp);
1780 /* If we do not have a built_in fmod, the calculation is going to
1781 have to be done longhand. */
1782 tmp = fold_build2_loc (input_location, RDIV_EXPR, type, args[0], args[1]);
1784 /* Test if the value is too large to handle sensibly. */
1785 gfc_set_model_kind (expr->ts.kind);
1787 n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1788 ikind = expr->ts.kind;
1791 n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1792 ikind = gfc_max_integer_kind;
1794 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1795 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1796 test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1799 mpfr_neg (huge, huge, GFC_RND_MODE);
1800 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1801 test = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
1803 test2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1804 boolean_type_node, test, test2);
1806 itype = gfc_get_int_type (ikind);
1808 tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1810 tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1811 tmp = convert (type, tmp);
1812 tmp = fold_build3_loc (input_location, COND_EXPR, type, test2, tmp,
1814 tmp = fold_build2_loc (input_location, MULT_EXPR, type, tmp, args[1]);
1815 se->expr = fold_build2_loc (input_location, MINUS_EXPR, type, args[0],
1825 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
1826 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
1827 where the right shifts are logical (i.e. 0's are shifted in).
1828 Because SHIFT_EXPR's want shifts strictly smaller than the integral
1829 type width, we have to special-case both S == 0 and S == BITSIZE(J):
1831 DSHIFTL(I,J,BITSIZE) = J
1833 DSHIFTR(I,J,BITSIZE) = I. */
1836 gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
1838 tree type, utype, stype, arg1, arg2, shift, res, left, right;
1839 tree args[3], cond, tmp;
1842 gfc_conv_intrinsic_function_args (se, expr, args, 3);
1844 gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
1845 type = TREE_TYPE (args[0]);
1846 bitsize = TYPE_PRECISION (type);
1847 utype = unsigned_type_for (type);
1848 stype = TREE_TYPE (args[2]);
1850 arg1 = gfc_evaluate_now (args[0], &se->pre);
1851 arg2 = gfc_evaluate_now (args[1], &se->pre);
1852 shift = gfc_evaluate_now (args[2], &se->pre);
1854 /* The generic case. */
1855 tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
1856 build_int_cst (stype, bitsize), shift);
1857 left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
1858 arg1, dshiftl ? shift : tmp);
1860 right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
1861 fold_convert (utype, arg2), dshiftl ? tmp : shift);
1862 right = fold_convert (type, right);
1864 res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
1866 /* Special cases. */
1867 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
1868 build_int_cst (stype, 0));
1869 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
1870 dshiftl ? arg1 : arg2, res);
1872 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
1873 build_int_cst (stype, bitsize));
1874 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
1875 dshiftl ? arg2 : arg1, res);
1881 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1884 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1892 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1893 type = TREE_TYPE (args[0]);
1895 val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
1896 val = gfc_evaluate_now (val, &se->pre);
1898 zero = gfc_build_const (type, integer_zero_node);
1899 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, val, zero);
1900 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
1904 /* SIGN(A, B) is absolute value of A times sign of B.
1905 The real value versions use library functions to ensure the correct
1906 handling of negative zero. Integer case implemented as:
1907 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1911 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1917 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1918 if (expr->ts.type == BT_REAL)
1922 tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
1923 abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
1925 /* We explicitly have to ignore the minus sign. We do so by using
1926 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1927 if (!gfc_option.flag_sign_zero
1928 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
1931 zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
1932 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1934 se->expr = fold_build3_loc (input_location, COND_EXPR,
1935 TREE_TYPE (args[0]), cond,
1936 build_call_expr_loc (input_location, abs, 1,
1938 build_call_expr_loc (input_location, tmp, 2,
1942 se->expr = build_call_expr_loc (input_location, tmp, 2,
1947 /* Having excluded floating point types, we know we are now dealing
1948 with signed integer types. */
1949 type = TREE_TYPE (args[0]);
1951 /* Args[0] is used multiple times below. */
1952 args[0] = gfc_evaluate_now (args[0], &se->pre);
1954 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1955 the signs of A and B are the same, and of all ones if they differ. */
1956 tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
1957 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
1958 build_int_cst (type, TYPE_PRECISION (type) - 1));
1959 tmp = gfc_evaluate_now (tmp, &se->pre);
1961 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1962 is all ones (i.e. -1). */
1963 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
1964 fold_build2_loc (input_location, PLUS_EXPR,
1965 type, args[0], tmp), tmp);
1969 /* Test for the presence of an optional argument. */
1972 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1976 arg = expr->value.function.actual->expr;
1977 gcc_assert (arg->expr_type == EXPR_VARIABLE);
1978 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1979 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1983 /* Calculate the double precision product of two single precision values. */
1986 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1991 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1993 /* Convert the args to double precision before multiplying. */
1994 type = gfc_typenode_for_spec (&expr->ts);
1995 args[0] = convert (type, args[0]);
1996 args[1] = convert (type, args[1]);
1997 se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
2002 /* Return a length one character string containing an ascii character. */
2005 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
2010 unsigned int num_args;
2012 num_args = gfc_intrinsic_argument_list_length (expr);
2013 gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
2015 type = gfc_get_char_type (expr->ts.kind);
2016 var = gfc_create_var (type, "char");
2018 arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
2019 gfc_add_modify (&se->pre, var, arg[0]);
2020 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
2021 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
2026 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
2034 unsigned int num_args;
2036 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2037 args = XALLOCAVEC (tree, num_args);
2039 var = gfc_create_var (pchar_type_node, "pstr");
2040 len = gfc_create_var (gfc_charlen_type_node, "len");
2042 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2043 args[0] = gfc_build_addr_expr (NULL_TREE, var);
2044 args[1] = gfc_build_addr_expr (NULL_TREE, len);
2046 fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
2047 tmp = build_call_array_loc (input_location,
2048 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
2049 fndecl, num_args, args);
2050 gfc_add_expr_to_block (&se->pre, tmp);
2052 /* Free the temporary afterwards, if necessary. */
2053 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2054 len, build_int_cst (TREE_TYPE (len), 0));
2055 tmp = gfc_call_free (var);
2056 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2057 gfc_add_expr_to_block (&se->post, tmp);
2060 se->string_length = len;
2065 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
2073 unsigned int num_args;
2075 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2076 args = XALLOCAVEC (tree, num_args);
2078 var = gfc_create_var (pchar_type_node, "pstr");
2079 len = gfc_create_var (gfc_charlen_type_node, "len");
2081 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2082 args[0] = gfc_build_addr_expr (NULL_TREE, var);
2083 args[1] = gfc_build_addr_expr (NULL_TREE, len);
2085 fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
2086 tmp = build_call_array_loc (input_location,
2087 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
2088 fndecl, num_args, args);
2089 gfc_add_expr_to_block (&se->pre, tmp);
2091 /* Free the temporary afterwards, if necessary. */
2092 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2093 len, build_int_cst (TREE_TYPE (len), 0));
2094 tmp = gfc_call_free (var);
2095 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2096 gfc_add_expr_to_block (&se->post, tmp);
2099 se->string_length = len;
2103 /* Return a character string containing the tty name. */
2106 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
2114 unsigned int num_args;
2116 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2117 args = XALLOCAVEC (tree, num_args);
2119 var = gfc_create_var (pchar_type_node, "pstr");
2120 len = gfc_create_var (gfc_charlen_type_node, "len");
2122 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2123 args[0] = gfc_build_addr_expr (NULL_TREE, var);
2124 args[1] = gfc_build_addr_expr (NULL_TREE, len);
2126 fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
2127 tmp = build_call_array_loc (input_location,
2128 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
2129 fndecl, num_args, args);
2130 gfc_add_expr_to_block (&se->pre, tmp);
2132 /* Free the temporary afterwards, if necessary. */
2133 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2134 len, build_int_cst (TREE_TYPE (len), 0));
2135 tmp = gfc_call_free (var);
2136 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2137 gfc_add_expr_to_block (&se->post, tmp);
2140 se->string_length = len;
2144 /* Get the minimum/maximum value of all the parameters.
2145 minmax (a1, a2, a3, ...)
2148 if (a2 .op. mvar || isnan(mvar))
2150 if (a3 .op. mvar || isnan(mvar))
2157 /* TODO: Mismatching types can occur when specific names are used.
2158 These should be handled during resolution. */
2160 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
2168 gfc_actual_arglist *argexpr;
2169 unsigned int i, nargs;
2171 nargs = gfc_intrinsic_argument_list_length (expr);
2172 args = XALLOCAVEC (tree, nargs);
2174 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
2175 type = gfc_typenode_for_spec (&expr->ts);
2177 argexpr = expr->value.function.actual;
2178 if (TREE_TYPE (args[0]) != type)
2179 args[0] = convert (type, args[0]);
2180 /* Only evaluate the argument once. */
2181 if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
2182 args[0] = gfc_evaluate_now (args[0], &se->pre);
2184 mvar = gfc_create_var (type, "M");
2185 gfc_add_modify (&se->pre, mvar, args[0]);
2186 for (i = 1, argexpr = argexpr->next; i < nargs; i++)
2192 /* Handle absent optional arguments by ignoring the comparison. */
2193 if (argexpr->expr->expr_type == EXPR_VARIABLE
2194 && argexpr->expr->symtree->n.sym->attr.optional
2195 && TREE_CODE (val) == INDIRECT_REF)
2196 cond = fold_build2_loc (input_location,
2197 NE_EXPR, boolean_type_node,
2198 TREE_OPERAND (val, 0),
2199 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
2204 /* Only evaluate the argument once. */
2205 if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
2206 val = gfc_evaluate_now (val, &se->pre);
2209 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
2211 tmp = fold_build2_loc (input_location, op, boolean_type_node,
2212 convert (type, val), mvar);
2214 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2215 __builtin_isnan might be made dependent on that module being loaded,
2216 to help performance of programs that don't rely on IEEE semantics. */
2217 if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
2219 isnan = build_call_expr_loc (input_location,
2220 builtin_decl_explicit (BUILT_IN_ISNAN),
2222 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2223 boolean_type_node, tmp,
2224 fold_convert (boolean_type_node, isnan));
2226 tmp = build3_v (COND_EXPR, tmp, thencase,
2227 build_empty_stmt (input_location));
2229 if (cond != NULL_TREE)
2230 tmp = build3_v (COND_EXPR, cond, tmp,
2231 build_empty_stmt (input_location));
2233 gfc_add_expr_to_block (&se->pre, tmp);
2234 argexpr = argexpr->next;
2240 /* Generate library calls for MIN and MAX intrinsics for character
2243 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
2246 tree var, len, fndecl, tmp, cond, function;
2249 nargs = gfc_intrinsic_argument_list_length (expr);
2250 args = XALLOCAVEC (tree, nargs + 4);
2251 gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
2253 /* Create the result variables. */
2254 len = gfc_create_var (gfc_charlen_type_node, "len");
2255 args[0] = gfc_build_addr_expr (NULL_TREE, len);
2256 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
2257 args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
2258 args[2] = build_int_cst (integer_type_node, op);
2259 args[3] = build_int_cst (integer_type_node, nargs / 2);
2261 if (expr->ts.kind == 1)
2262 function = gfor_fndecl_string_minmax;
2263 else if (expr->ts.kind == 4)
2264 function = gfor_fndecl_string_minmax_char4;
2268 /* Make the function call. */
2269 fndecl = build_addr (function, current_function_decl);
2270 tmp = build_call_array_loc (input_location,
2271 TREE_TYPE (TREE_TYPE (function)), fndecl,
2273 gfc_add_expr_to_block (&se->pre, tmp);
2275 /* Free the temporary afterwards, if necessary. */
2276 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2277 len, build_int_cst (TREE_TYPE (len), 0));
2278 tmp = gfc_call_free (var);
2279 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2280 gfc_add_expr_to_block (&se->post, tmp);
2283 se->string_length = len;
2287 /* Create a symbol node for this intrinsic. The symbol from the frontend
2288 has the generic name. */
2291 gfc_get_symbol_for_expr (gfc_expr * expr)
2295 /* TODO: Add symbols for intrinsic function to the global namespace. */
2296 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
2297 sym = gfc_new_symbol (expr->value.function.name, NULL);
2300 sym->attr.external = 1;
2301 sym->attr.function = 1;
2302 sym->attr.always_explicit = 1;
2303 sym->attr.proc = PROC_INTRINSIC;
2304 sym->attr.flavor = FL_PROCEDURE;
2308 sym->attr.dimension = 1;
2309 sym->as = gfc_get_array_spec ();
2310 sym->as->type = AS_ASSUMED_SHAPE;
2311 sym->as->rank = expr->rank;
2314 gfc_copy_formal_args_intr (sym, expr->value.function.isym);
2319 /* Generate a call to an external intrinsic function. */
2321 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
2324 VEC(tree,gc) *append_args;
2326 gcc_assert (!se->ss || se->ss->expr == expr);
2329 gcc_assert (expr->rank > 0);
2331 gcc_assert (expr->rank == 0);
2333 sym = gfc_get_symbol_for_expr (expr);
2335 /* Calls to libgfortran_matmul need to be appended special arguments,
2336 to be able to call the BLAS ?gemm functions if required and possible. */
2338 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
2339 && sym->ts.type != BT_LOGICAL)
2341 tree cint = gfc_get_int_type (gfc_c_int_kind);
2343 if (gfc_option.flag_external_blas
2344 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
2345 && (sym->ts.kind == gfc_default_real_kind
2346 || sym->ts.kind == gfc_default_double_kind))
2350 if (sym->ts.type == BT_REAL)
2352 if (sym->ts.kind == gfc_default_real_kind)
2353 gemm_fndecl = gfor_fndecl_sgemm;
2355 gemm_fndecl = gfor_fndecl_dgemm;
2359 if (sym->ts.kind == gfc_default_real_kind)
2360 gemm_fndecl = gfor_fndecl_cgemm;
2362 gemm_fndecl = gfor_fndecl_zgemm;
2365 append_args = VEC_alloc (tree, gc, 3);
2366 VEC_quick_push (tree, append_args, build_int_cst (cint, 1));
2367 VEC_quick_push (tree, append_args,
2368 build_int_cst (cint, gfc_option.blas_matmul_limit));
2369 VEC_quick_push (tree, append_args,
2370 gfc_build_addr_expr (NULL_TREE, gemm_fndecl));
2374 append_args = VEC_alloc (tree, gc, 3);
2375 VEC_quick_push (tree, append_args, build_int_cst (cint, 0));
2376 VEC_quick_push (tree, append_args, build_int_cst (cint, 0));
2377 VEC_quick_push (tree, append_args, null_pointer_node);
2381 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
2383 gfc_free_symbol (sym);
2386 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
2406 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
2415 gfc_actual_arglist *actual;
2422 gfc_conv_intrinsic_funcall (se, expr);
2426 actual = expr->value.function.actual;
2427 type = gfc_typenode_for_spec (&expr->ts);
2428 /* Initialize the result. */
2429 resvar = gfc_create_var (type, "test");
2431 tmp = convert (type, boolean_true_node);
2433 tmp = convert (type, boolean_false_node);
2434 gfc_add_modify (&se->pre, resvar, tmp);
2436 /* Walk the arguments. */
2437 arrayss = gfc_walk_expr (actual->expr);
2438 gcc_assert (arrayss != gfc_ss_terminator);
2440 /* Initialize the scalarizer. */
2441 gfc_init_loopinfo (&loop);
2442 exit_label = gfc_build_label_decl (NULL_TREE);
2443 TREE_USED (exit_label) = 1;
2444 gfc_add_ss_to_loop (&loop, arrayss);
2446 /* Initialize the loop. */
2447 gfc_conv_ss_startstride (&loop);
2448 gfc_conv_loop_setup (&loop, &expr->where);
2450 gfc_mark_ss_chain_used (arrayss, 1);
2451 /* Generate the loop body. */
2452 gfc_start_scalarized_body (&loop, &body);
2454 /* If the condition matches then set the return value. */
2455 gfc_start_block (&block);
2457 tmp = convert (type, boolean_false_node);
2459 tmp = convert (type, boolean_true_node);
2460 gfc_add_modify (&block, resvar, tmp);
2462 /* And break out of the loop. */
2463 tmp = build1_v (GOTO_EXPR, exit_label);
2464 gfc_add_expr_to_block (&block, tmp);
2466 found = gfc_finish_block (&block);
2468 /* Check this element. */
2469 gfc_init_se (&arrayse, NULL);
2470 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2471 arrayse.ss = arrayss;
2472 gfc_conv_expr_val (&arrayse, actual->expr);
2474 gfc_add_block_to_block (&body, &arrayse.pre);
2475 tmp = fold_build2_loc (input_location, op, boolean_type_node, arrayse.expr,
2476 build_int_cst (TREE_TYPE (arrayse.expr), 0));
2477 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
2478 gfc_add_expr_to_block (&body, tmp);
2479 gfc_add_block_to_block (&body, &arrayse.post);
2481 gfc_trans_scalarizing_loops (&loop, &body);
2483 /* Add the exit label. */
2484 tmp = build1_v (LABEL_EXPR, exit_label);
2485 gfc_add_expr_to_block (&loop.pre, tmp);
2487 gfc_add_block_to_block (&se->pre, &loop.pre);
2488 gfc_add_block_to_block (&se->pre, &loop.post);
2489 gfc_cleanup_loop (&loop);
2494 /* COUNT(A) = Number of true elements in A. */
2496 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
2503 gfc_actual_arglist *actual;
2509 gfc_conv_intrinsic_funcall (se, expr);
2513 actual = expr->value.function.actual;
2515 type = gfc_typenode_for_spec (&expr->ts);
2516 /* Initialize the result. */
2517 resvar = gfc_create_var (type, "count");
2518 gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
2520 /* Walk the arguments. */
2521 arrayss = gfc_walk_expr (actual->expr);
2522 gcc_assert (arrayss != gfc_ss_terminator);
2524 /* Initialize the scalarizer. */
2525 gfc_init_loopinfo (&loop);
2526 gfc_add_ss_to_loop (&loop, arrayss);
2528 /* Initialize the loop. */
2529 gfc_conv_ss_startstride (&loop);
2530 gfc_conv_loop_setup (&loop, &expr->where);
2532 gfc_mark_ss_chain_used (arrayss, 1);
2533 /* Generate the loop body. */
2534 gfc_start_scalarized_body (&loop, &body);
2536 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
2537 resvar, build_int_cst (TREE_TYPE (resvar), 1));
2538 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
2540 gfc_init_se (&arrayse, NULL);
2541 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2542 arrayse.ss = arrayss;
2543 gfc_conv_expr_val (&arrayse, actual->expr);
2544 tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
2545 build_empty_stmt (input_location));
2547 gfc_add_block_to_block (&body, &arrayse.pre);
2548 gfc_add_expr_to_block (&body, tmp);
2549 gfc_add_block_to_block (&body, &arrayse.post);
2551 gfc_trans_scalarizing_loops (&loop, &body);
2553 gfc_add_block_to_block (&se->pre, &loop.pre);
2554 gfc_add_block_to_block (&se->pre, &loop.post);
2555 gfc_cleanup_loop (&loop);
2560 /* Inline implementation of the sum and product intrinsics. */
2562 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
2566 tree scale = NULL_TREE;
2572 gfc_actual_arglist *actual;
2577 gfc_expr *arrayexpr;
2582 gfc_conv_intrinsic_funcall (se, expr);
2586 type = gfc_typenode_for_spec (&expr->ts);
2587 /* Initialize the result. */
2588 resvar = gfc_create_var (type, "val");
2593 scale = gfc_create_var (type, "scale");
2594 gfc_add_modify (&se->pre, scale,
2595 gfc_build_const (type, integer_one_node));
2596 tmp = gfc_build_const (type, integer_zero_node);
2598 else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
2599 tmp = gfc_build_const (type, integer_zero_node);
2600 else if (op == NE_EXPR)
2602 tmp = convert (type, boolean_false_node);
2603 else if (op == BIT_AND_EXPR)
2604 tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
2605 type, integer_one_node));
2607 tmp = gfc_build_const (type, integer_one_node);
2609 gfc_add_modify (&se->pre, resvar, tmp);
2611 /* Walk the arguments. */
2612 actual = expr->value.function.actual;
2613 arrayexpr = actual->expr;
2614 arrayss = gfc_walk_expr (arrayexpr);
2615 gcc_assert (arrayss != gfc_ss_terminator);
2617 if (op == NE_EXPR || norm2)
2618 /* PARITY and NORM2. */
2622 actual = actual->next->next;
2623 gcc_assert (actual);
2624 maskexpr = actual->expr;
2627 if (maskexpr && maskexpr->rank != 0)
2629 maskss = gfc_walk_expr (maskexpr);
2630 gcc_assert (maskss != gfc_ss_terminator);
2635 /* Initialize the scalarizer. */
2636 gfc_init_loopinfo (&loop);
2637 gfc_add_ss_to_loop (&loop, arrayss);
2639 gfc_add_ss_to_loop (&loop, maskss);
2641 /* Initialize the loop. */
2642 gfc_conv_ss_startstride (&loop);
2643 gfc_conv_loop_setup (&loop, &expr->where);
2645 gfc_mark_ss_chain_used (arrayss, 1);
2647 gfc_mark_ss_chain_used (maskss, 1);
2648 /* Generate the loop body. */
2649 gfc_start_scalarized_body (&loop, &body);
2651 /* If we have a mask, only add this element if the mask is set. */
2654 gfc_init_se (&maskse, NULL);
2655 gfc_copy_loopinfo_to_se (&maskse, &loop);
2657 gfc_conv_expr_val (&maskse, maskexpr);
2658 gfc_add_block_to_block (&body, &maskse.pre);
2660 gfc_start_block (&block);
2663 gfc_init_block (&block);
2665 /* Do the actual summation/product. */
2666 gfc_init_se (&arrayse, NULL);
2667 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2668 arrayse.ss = arrayss;
2669 gfc_conv_expr_val (&arrayse, arrayexpr);
2670 gfc_add_block_to_block (&block, &arrayse.pre);
2680 result = 1.0 + result * val * val;
2686 result += val * val;
2689 tree res1, res2, cond, absX, val;
2690 stmtblock_t ifblock1, ifblock2, ifblock3;
2692 gfc_init_block (&ifblock1);
2694 absX = gfc_create_var (type, "absX");
2695 gfc_add_modify (&ifblock1, absX,
2696 fold_build1_loc (input_location, ABS_EXPR, type,
2698 val = gfc_create_var (type, "val");
2699 gfc_add_expr_to_block (&ifblock1, val);
2701 gfc_init_block (&ifblock2);
2702 gfc_add_modify (&ifblock2, val,
2703 fold_build2_loc (input_location, RDIV_EXPR, type, scale,
2705 res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
2706 res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
2707 res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
2708 gfc_build_const (type, integer_one_node));
2709 gfc_add_modify (&ifblock2, resvar, res1);
2710 gfc_add_modify (&ifblock2, scale, absX);
2711 res1 = gfc_finish_block (&ifblock2);
2713 gfc_init_block (&ifblock3);
2714 gfc_add_modify (&ifblock3, val,
2715 fold_build2_loc (input_location, RDIV_EXPR, type, absX,
2717 res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
2718 res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
2719 gfc_add_modify (&ifblock3, resvar, res2);
2720 res2 = gfc_finish_block (&ifblock3);
2722 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2724 tmp = build3_v (COND_EXPR, cond, res1, res2);
2725 gfc_add_expr_to_block (&ifblock1, tmp);
2726 tmp = gfc_finish_block (&ifblock1);
2728 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2730 gfc_build_const (type, integer_zero_node));
2732 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2733 gfc_add_expr_to_block (&block, tmp);
2737 tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
2738 gfc_add_modify (&block, resvar, tmp);
2741 gfc_add_block_to_block (&block, &arrayse.post);
2745 /* We enclose the above in if (mask) {...} . */
2747 tmp = gfc_finish_block (&block);
2748 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2749 build_empty_stmt (input_location));
2752 tmp = gfc_finish_block (&block);
2753 gfc_add_expr_to_block (&body, tmp);
2755 gfc_trans_scalarizing_loops (&loop, &body);
2757 /* For a scalar mask, enclose the loop in an if statement. */
2758 if (maskexpr && maskss == NULL)
2760 gfc_init_se (&maskse, NULL);
2761 gfc_conv_expr_val (&maskse, maskexpr);
2762 gfc_init_block (&block);
2763 gfc_add_block_to_block (&block, &loop.pre);
2764 gfc_add_block_to_block (&block, &loop.post);
2765 tmp = gfc_finish_block (&block);
2767 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2768 build_empty_stmt (input_location));
2769 gfc_add_expr_to_block (&block, tmp);
2770 gfc_add_block_to_block (&se->pre, &block);
2774 gfc_add_block_to_block (&se->pre, &loop.pre);
2775 gfc_add_block_to_block (&se->pre, &loop.post);
2778 gfc_cleanup_loop (&loop);
2782 /* result = scale * sqrt(result). */
2784 sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
2785 resvar = build_call_expr_loc (input_location,
2787 resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
2794 /* Inline implementation of the dot_product intrinsic. This function
2795 is based on gfc_conv_intrinsic_arith (the previous function). */
2797 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2805 gfc_actual_arglist *actual;
2806 gfc_ss *arrayss1, *arrayss2;
2807 gfc_se arrayse1, arrayse2;
2808 gfc_expr *arrayexpr1, *arrayexpr2;
2810 type = gfc_typenode_for_spec (&expr->ts);
2812 /* Initialize the result. */
2813 resvar = gfc_create_var (type, "val");
2814 if (expr->ts.type == BT_LOGICAL)
2815 tmp = build_int_cst (type, 0);
2817 tmp = gfc_build_const (type, integer_zero_node);
2819 gfc_add_modify (&se->pre, resvar, tmp);
2821 /* Walk argument #1. */
2822 actual = expr->value.function.actual;
2823 arrayexpr1 = actual->expr;
2824 arrayss1 = gfc_walk_expr (arrayexpr1);
2825 gcc_assert (arrayss1 != gfc_ss_terminator);
2827 /* Walk argument #2. */
2828 actual = actual->next;
2829 arrayexpr2 = actual->expr;
2830 arrayss2 = gfc_walk_expr (arrayexpr2);
2831 gcc_assert (arrayss2 != gfc_ss_terminator);
2833 /* Initialize the scalarizer. */
2834 gfc_init_loopinfo (&loop);
2835 gfc_add_ss_to_loop (&loop, arrayss1);
2836 gfc_add_ss_to_loop (&loop, arrayss2);
2838 /* Initialize the loop. */
2839 gfc_conv_ss_startstride (&loop);
2840 gfc_conv_loop_setup (&loop, &expr->where);
2842 gfc_mark_ss_chain_used (arrayss1, 1);
2843 gfc_mark_ss_chain_used (arrayss2, 1);
2845 /* Generate the loop body. */
2846 gfc_start_scalarized_body (&loop, &body);
2847 gfc_init_block (&block);
2849 /* Make the tree expression for [conjg(]array1[)]. */
2850 gfc_init_se (&arrayse1, NULL);
2851 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2852 arrayse1.ss = arrayss1;
2853 gfc_conv_expr_val (&arrayse1, arrayexpr1);
2854 if (expr->ts.type == BT_COMPLEX)
2855 arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
2857 gfc_add_block_to_block (&block, &arrayse1.pre);
2859 /* Make the tree expression for array2. */
2860 gfc_init_se (&arrayse2, NULL);
2861 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2862 arrayse2.ss = arrayss2;
2863 gfc_conv_expr_val (&arrayse2, arrayexpr2);
2864 gfc_add_block_to_block (&block, &arrayse2.pre);
2866 /* Do the actual product and sum. */
2867 if (expr->ts.type == BT_LOGICAL)
2869 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
2870 arrayse1.expr, arrayse2.expr);
2871 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
2875 tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
2877 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
2879 gfc_add_modify (&block, resvar, tmp);
2881 /* Finish up the loop block and the loop. */
2882 tmp = gfc_finish_block (&block);
2883 gfc_add_expr_to_block (&body, tmp);
2885 gfc_trans_scalarizing_loops (&loop, &body);
2886 gfc_add_block_to_block (&se->pre, &loop.pre);
2887 gfc_add_block_to_block (&se->pre, &loop.post);
2888 gfc_cleanup_loop (&loop);
2894 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2895 we need to handle. For performance reasons we sometimes create two
2896 loops instead of one, where the second one is much simpler.
2897 Examples for minloc intrinsic:
2898 1) Result is an array, a call is generated
2899 2) Array mask is used and NaNs need to be supported:
2905 if (pos == 0) pos = S + (1 - from);
2906 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2913 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2917 3) NaNs need to be supported, but it is known at compile time or cheaply
2918 at runtime whether array is nonempty or not:
2923 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2926 if (from <= to) pos = 1;
2930 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2934 4) NaNs aren't supported, array mask is used:
2935 limit = infinities_supported ? Infinity : huge (limit);
2939 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2945 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2949 5) Same without array mask:
2950 limit = infinities_supported ? Infinity : huge (limit);
2951 pos = (from <= to) ? 1 : 0;
2954 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2957 For 3) and 5), if mask is scalar, this all goes into a conditional,
2958 setting pos = 0; in the else branch. */
2961 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
2965 stmtblock_t ifblock;
2966 stmtblock_t elseblock;
2977 gfc_actual_arglist *actual;
2982 gfc_expr *arrayexpr;
2989 gfc_conv_intrinsic_funcall (se, expr);
2993 /* Initialize the result. */
2994 pos = gfc_create_var (gfc_array_index_type, "pos");
2995 offset = gfc_create_var (gfc_array_index_type, "offset");
2996 type = gfc_typenode_for_spec (&expr->ts);
2998 /* Walk the arguments. */
2999 actual = expr->value.function.actual;
3000 arrayexpr = actual->expr;
3001 arrayss = gfc_walk_expr (arrayexpr);
3002 gcc_assert (arrayss != gfc_ss_terminator);
3004 actual = actual->next->next;
3005 gcc_assert (actual);
3006 maskexpr = actual->expr;
3008 if (maskexpr && maskexpr->rank != 0)
3010 maskss = gfc_walk_expr (maskexpr);
3011 gcc_assert (maskss != gfc_ss_terminator);
3016 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
3018 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
3020 nonempty = fold_build2_loc (input_location, GT_EXPR,
3021 boolean_type_node, nonempty,
3022 gfc_index_zero_node);
3027 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
3028 switch (arrayexpr->ts.type)
3031 tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
3035 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
3036 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
3037 arrayexpr->ts.kind);
3044 /* We start with the most negative possible value for MAXLOC, and the most
3045 positive possible value for MINLOC. The most negative possible value is
3046 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3047 possible value is HUGE in both cases. */
3049 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
3050 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
3051 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
3052 build_int_cst (type, 1));
3054 gfc_add_modify (&se->pre, limit, tmp);
3056 /* Initialize the scalarizer. */
3057 gfc_init_loopinfo (&loop);
3058 gfc_add_ss_to_loop (&loop, arrayss);
3060 gfc_add_ss_to_loop (&loop, maskss);
3062 /* Initialize the loop. */
3063 gfc_conv_ss_startstride (&loop);
3064 gfc_conv_loop_setup (&loop, &expr->where);
3066 gcc_assert (loop.dimen == 1);
3067 if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
3068 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3069 loop.from[0], loop.to[0]);
3073 /* Initialize the position to zero, following Fortran 2003. We are free
3074 to do this because Fortran 95 allows the result of an entirely false
3075 mask to be processor dependent. If we know at compile time the array
3076 is non-empty and no MASK is used, we can initialize to 1 to simplify
3078 if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
3079 gfc_add_modify (&loop.pre, pos,
3080 fold_build3_loc (input_location, COND_EXPR,
3081 gfc_array_index_type,
3082 nonempty, gfc_index_one_node,
3083 gfc_index_zero_node));
3086 gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
3087 lab1 = gfc_build_label_decl (NULL_TREE);
3088 TREE_USED (lab1) = 1;
3089 lab2 = gfc_build_label_decl (NULL_TREE);
3090 TREE_USED (lab2) = 1;
3093 gfc_mark_ss_chain_used (arrayss, 1);
3095 gfc_mark_ss_chain_used (maskss, 1);
3096 /* Generate the loop body. */
3097 gfc_start_scalarized_body (&loop, &body);
3099 /* If we have a mask, only check this element if the mask is set. */
3102 gfc_init_se (&maskse, NULL);
3103 gfc_copy_loopinfo_to_se (&maskse, &loop);
3105 gfc_conv_expr_val (&maskse, maskexpr);
3106 gfc_add_block_to_block (&body, &maskse.pre);
3108 gfc_start_block (&block);
3111 gfc_init_block (&block);
3113 /* Compare with the current limit. */
3114 gfc_init_se (&arrayse, NULL);
3115 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3116 arrayse.ss = arrayss;
3117 gfc_conv_expr_val (&arrayse, arrayexpr);
3118 gfc_add_block_to_block (&block, &arrayse.pre);
3120 /* We do the following if this is a more extreme value. */
3121 gfc_start_block (&ifblock);
3123 /* Assign the value to the limit... */
3124 gfc_add_modify (&ifblock, limit, arrayse.expr);
3126 /* Remember where we are. An offset must be added to the loop
3127 counter to obtain the required position. */
3129 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3130 gfc_index_one_node, loop.from[0]);
3132 tmp = gfc_index_one_node;
3134 gfc_add_modify (&block, offset, tmp);
3136 if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
3138 stmtblock_t ifblock2;
3141 gfc_start_block (&ifblock2);
3142 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3143 loop.loopvar[0], offset);
3144 gfc_add_modify (&ifblock2, pos, tmp);
3145 ifbody2 = gfc_finish_block (&ifblock2);
3146 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pos,
3147 gfc_index_zero_node);
3148 tmp = build3_v (COND_EXPR, cond, ifbody2,
3149 build_empty_stmt (input_location));
3150 gfc_add_expr_to_block (&block, tmp);
3153 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3154 loop.loopvar[0], offset);
3155 gfc_add_modify (&ifblock, pos, tmp);
3158 gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
3160 ifbody = gfc_finish_block (&ifblock);
3162 if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
3165 cond = fold_build2_loc (input_location,
3166 op == GT_EXPR ? GE_EXPR : LE_EXPR,
3167 boolean_type_node, arrayse.expr, limit);
3169 cond = fold_build2_loc (input_location, op, boolean_type_node,
3170 arrayse.expr, limit);
3172 ifbody = build3_v (COND_EXPR, cond, ifbody,
3173 build_empty_stmt (input_location));
3175 gfc_add_expr_to_block (&block, ifbody);
3179 /* We enclose the above in if (mask) {...}. */
3180 tmp = gfc_finish_block (&block);
3182 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3183 build_empty_stmt (input_location));
3186 tmp = gfc_finish_block (&block);
3187 gfc_add_expr_to_block (&body, tmp);
3191 gfc_trans_scalarized_loop_end (&loop, 0, &body);
3193 if (HONOR_NANS (DECL_MODE (limit)))
3195 if (nonempty != NULL)
3197 ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
3198 tmp = build3_v (COND_EXPR, nonempty, ifbody,
3199 build_empty_stmt (input_location));
3200 gfc_add_expr_to_block (&loop.code[0], tmp);
3204 gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
3205 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
3206 gfc_start_block (&body);
3208 /* If we have a mask, only check this element if the mask is set. */
3211 gfc_init_se (&maskse, NULL);
3212 gfc_copy_loopinfo_to_se (&maskse, &loop);
3214 gfc_conv_expr_val (&maskse, maskexpr);
3215 gfc_add_block_to_block (&body, &maskse.pre);
3217 gfc_start_block (&block);
3220 gfc_init_block (&block);
3222 /* Compare with the current limit. */
3223 gfc_init_se (&arrayse, NULL);
3224 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3225 arrayse.ss = arrayss;
3226 gfc_conv_expr_val (&arrayse, arrayexpr);
3227 gfc_add_block_to_block (&block, &arrayse.pre);
3229 /* We do the following if this is a more extreme value. */
3230 gfc_start_block (&ifblock);
3232 /* Assign the value to the limit... */
3233 gfc_add_modify (&ifblock, limit, arrayse.expr);
3235 /* Remember where we are. An offset must be added to the loop
3236 counter to obtain the required position. */
3238 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3239 gfc_index_one_node, loop.from[0]);
3241 tmp = gfc_index_one_node;
3243 gfc_add_modify (&block, offset, tmp);
3245 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3246 loop.loopvar[0], offset);
3247 gfc_add_modify (&ifblock, pos, tmp);
3249 ifbody = gfc_finish_block (&ifblock);
3251 cond = fold_build2_loc (input_location, op, boolean_type_node,
3252 arrayse.expr, limit);
3254 tmp = build3_v (COND_EXPR, cond, ifbody,
3255 build_empty_stmt (input_location));
3256 gfc_add_expr_to_block (&block, tmp);
3260 /* We enclose the above in if (mask) {...}. */
3261 tmp = gfc_finish_block (&block);
3263 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3264 build_empty_stmt (input_location));
3267 tmp = gfc_finish_block (&block);
3268 gfc_add_expr_to_block (&body, tmp);
3269 /* Avoid initializing loopvar[0] again, it should be left where
3270 it finished by the first loop. */
3271 loop.from[0] = loop.loopvar[0];
3274 gfc_trans_scalarizing_loops (&loop, &body);
3277 gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
3279 /* For a scalar mask, enclose the loop in an if statement. */
3280 if (maskexpr && maskss == NULL)
3282 gfc_init_se (&maskse, NULL);
3283 gfc_conv_expr_val (&maskse, maskexpr);
3284 gfc_init_block (&block);
3285 gfc_add_block_to_block (&block, &loop.pre);
3286 gfc_add_block_to_block (&block, &loop.post);
3287 tmp = gfc_finish_block (&block);
3289 /* For the else part of the scalar mask, just initialize
3290 the pos variable the same way as above. */
3292 gfc_init_block (&elseblock);
3293 gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
3294 elsetmp = gfc_finish_block (&elseblock);
3296 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
3297 gfc_add_expr_to_block (&block, tmp);
3298 gfc_add_block_to_block (&se->pre, &block);
3302 gfc_add_block_to_block (&se->pre, &loop.pre);
3303 gfc_add_block_to_block (&se->pre, &loop.post);
3305 gfc_cleanup_loop (&loop);
3307 se->expr = convert (type, pos);
3310 /* Emit code for minval or maxval intrinsic. There are many different cases
3311 we need to handle. For performance reasons we sometimes create two
3312 loops instead of one, where the second one is much simpler.
3313 Examples for minval intrinsic:
3314 1) Result is an array, a call is generated
3315 2) Array mask is used and NaNs need to be supported, rank 1:
3320 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
3323 limit = nonempty ? NaN : huge (limit);
3325 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
3326 3) NaNs need to be supported, but it is known at compile time or cheaply
3327 at runtime whether array is nonempty or not, rank 1:
3330 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
3331 limit = (from <= to) ? NaN : huge (limit);
3333 while (S <= to) { limit = min (a[S], limit); S++; }
3334 4) Array mask is used and NaNs need to be supported, rank > 1:
3343 if (fast) limit = min (a[S1][S2], limit);
3346 if (a[S1][S2] <= limit) {
3357 limit = nonempty ? NaN : huge (limit);
3358 5) NaNs need to be supported, but it is known at compile time or cheaply
3359 at runtime whether array is nonempty or not, rank > 1:
3366 if (fast) limit = min (a[S1][S2], limit);
3368 if (a[S1][S2] <= limit) {
3378 limit = (nonempty_array) ? NaN : huge (limit);
3379 6) NaNs aren't supported, but infinities are. Array mask is used:
3384 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
3387 limit = nonempty ? limit : huge (limit);
3388 7) Same without array mask:
3391 while (S <= to) { limit = min (a[S], limit); S++; }
3392 limit = (from <= to) ? limit : huge (limit);
3393 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
3394 limit = huge (limit);
3396 while (S <= to) { limit = min (a[S], limit); S++); }
3398 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
3399 with array mask instead).
3400 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
3401 setting limit = huge (limit); in the else branch. */
3404 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
3414 tree huge_cst = NULL, nan_cst = NULL;
3416 stmtblock_t block, block2;
3418 gfc_actual_arglist *actual;
3423 gfc_expr *arrayexpr;
3429 gfc_conv_intrinsic_funcall (se, expr);
3433 type = gfc_typenode_for_spec (&expr->ts);
3434 /* Initialize the result. */
3435 limit = gfc_create_var (type, "limit");
3436 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
3437 switch (expr->ts.type)
3440 huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
3442 if (HONOR_INFINITIES (DECL_MODE (limit)))
3444 REAL_VALUE_TYPE real;
3446 tmp = build_real (type, real);
3450 if (HONOR_NANS (DECL_MODE (limit)))
3452 REAL_VALUE_TYPE real;
3453 real_nan (&real, "", 1, DECL_MODE (limit));
3454 nan_cst = build_real (type, real);
3459 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
3466 /* We start with the most negative possible value for MAXVAL, and the most
3467 positive possible value for MINVAL. The most negative possible value is
3468 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3469 possible value is HUGE in both cases. */
3472 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
3474 huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
3475 TREE_TYPE (huge_cst), huge_cst);
3478 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
3479 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
3480 tmp, build_int_cst (type, 1));
3482 gfc_add_modify (&se->pre, limit, tmp);
3484 /* Walk the arguments. */
3485 actual = expr->value.function.actual;
3486 arrayexpr = actual->expr;
3487 arrayss = gfc_walk_expr (arrayexpr);
3488 gcc_assert (arrayss != gfc_ss_terminator);
3490 actual = actual->next->next;
3491 gcc_assert (actual);
3492 maskexpr = actual->expr;
3494 if (maskexpr && maskexpr->rank != 0)
3496 maskss = gfc_walk_expr (maskexpr);
3497 gcc_assert (maskss != gfc_ss_terminator);
3502 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
3504 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
3506 nonempty = fold_build2_loc (input_location, GT_EXPR,
3507 boolean_type_node, nonempty,
3508 gfc_index_zero_node);
3513 /* Initialize the scalarizer. */
3514 gfc_init_loopinfo (&loop);
3515 gfc_add_ss_to_loop (&loop, arrayss);
3517 gfc_add_ss_to_loop (&loop, maskss);
3519 /* Initialize the loop. */
3520 gfc_conv_ss_startstride (&loop);
3521 gfc_conv_loop_setup (&loop, &expr->where);
3523 if (nonempty == NULL && maskss == NULL
3524 && loop.dimen == 1 && loop.from[0] && loop.to[0])
3525 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3526 loop.from[0], loop.to[0]);
3527 nonempty_var = NULL;
3528 if (nonempty == NULL
3529 && (HONOR_INFINITIES (DECL_MODE (limit))
3530 || HONOR_NANS (DECL_MODE (limit))))
3532 nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
3533 gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
3534 nonempty = nonempty_var;
3538 if (HONOR_NANS (DECL_MODE (limit)))
3540 if (loop.dimen == 1)
3542 lab = gfc_build_label_decl (NULL_TREE);
3543 TREE_USED (lab) = 1;
3547 fast = gfc_create_var (boolean_type_node, "fast");
3548 gfc_add_modify (&se->pre, fast, boolean_false_node);
3552 gfc_mark_ss_chain_used (arrayss, 1);
3554 gfc_mark_ss_chain_used (maskss, 1);
3555 /* Generate the loop body. */
3556 gfc_start_scalarized_body (&loop, &body);
3558 /* If we have a mask, only add this element if the mask is set. */
3561 gfc_init_se (&maskse, NULL);
3562 gfc_copy_loopinfo_to_se (&maskse, &loop);
3564 gfc_conv_expr_val (&maskse, maskexpr);
3565 gfc_add_block_to_block (&body, &maskse.pre);
3567 gfc_start_block (&block);
3570 gfc_init_block (&block);
3572 /* Compare with the current limit. */
3573 gfc_init_se (&arrayse, NULL);
3574 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3575 arrayse.ss = arrayss;
3576 gfc_conv_expr_val (&arrayse, arrayexpr);
3577 gfc_add_block_to_block (&block, &arrayse.pre);
3579 gfc_init_block (&block2);
3582 gfc_add_modify (&block2, nonempty_var, boolean_true_node);
3584 if (HONOR_NANS (DECL_MODE (limit)))
3586 tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
3587 boolean_type_node, arrayse.expr, limit);
3589 ifbody = build1_v (GOTO_EXPR, lab);
3592 stmtblock_t ifblock;
3594 gfc_init_block (&ifblock);
3595 gfc_add_modify (&ifblock, limit, arrayse.expr);
3596 gfc_add_modify (&ifblock, fast, boolean_true_node);
3597 ifbody = gfc_finish_block (&ifblock);
3599 tmp = build3_v (COND_EXPR, tmp, ifbody,
3600 build_empty_stmt (input_location));
3601 gfc_add_expr_to_block (&block2, tmp);
3605 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3607 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3609 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3610 arrayse.expr, limit);
3611 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3612 tmp = build3_v (COND_EXPR, tmp, ifbody,
3613 build_empty_stmt (input_location));
3614 gfc_add_expr_to_block (&block2, tmp);
3618 tmp = fold_build2_loc (input_location,
3619 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3620 type, arrayse.expr, limit);
3621 gfc_add_modify (&block2, limit, tmp);
3627 tree elsebody = gfc_finish_block (&block2);
3629 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3631 if (HONOR_NANS (DECL_MODE (limit))
3632 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3634 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3635 arrayse.expr, limit);
3636 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3637 ifbody = build3_v (COND_EXPR, tmp, ifbody,
3638 build_empty_stmt (input_location));
3642 tmp = fold_build2_loc (input_location,
3643 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3644 type, arrayse.expr, limit);
3645 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
3647 tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
3648 gfc_add_expr_to_block (&block, tmp);
3651 gfc_add_block_to_block (&block, &block2);
3653 gfc_add_block_to_block (&block, &arrayse.post);
3655 tmp = gfc_finish_block (&block);
3657 /* We enclose the above in if (mask) {...}. */
3658 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3659 build_empty_stmt (input_location));
3660 gfc_add_expr_to_block (&body, tmp);
3664 gfc_trans_scalarized_loop_end (&loop, 0, &body);
3666 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
3668 gfc_add_modify (&loop.code[0], limit, tmp);
3669 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
3671 gfc_start_block (&body);
3673 /* If we have a mask, only add this element if the mask is set. */
3676 gfc_init_se (&maskse, NULL);
3677 gfc_copy_loopinfo_to_se (&maskse, &loop);
3679 gfc_conv_expr_val (&maskse, maskexpr);
3680 gfc_add_block_to_block (&body, &maskse.pre);
3682 gfc_start_block (&block);
3685 gfc_init_block (&block);
3687 /* Compare with the current limit. */
3688 gfc_init_se (&arrayse, NULL);
3689 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3690 arrayse.ss = arrayss;
3691 gfc_conv_expr_val (&arrayse, arrayexpr);
3692 gfc_add_block_to_block (&block, &arrayse.pre);
3694 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3696 if (HONOR_NANS (DECL_MODE (limit))
3697 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3699 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3700 arrayse.expr, limit);
3701 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3702 tmp = build3_v (COND_EXPR, tmp, ifbody,
3703 build_empty_stmt (input_location));
3704 gfc_add_expr_to_block (&block, tmp);
3708 tmp = fold_build2_loc (input_location,
3709 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3710 type, arrayse.expr, limit);
3711 gfc_add_modify (&block, limit, tmp);
3714 gfc_add_block_to_block (&block, &arrayse.post);
3716 tmp = gfc_finish_block (&block);
3718 /* We enclose the above in if (mask) {...}. */
3719 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3720 build_empty_stmt (input_location));
3721 gfc_add_expr_to_block (&body, tmp);
3722 /* Avoid initializing loopvar[0] again, it should be left where
3723 it finished by the first loop. */
3724 loop.from[0] = loop.loopvar[0];
3726 gfc_trans_scalarizing_loops (&loop, &body);
3730 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
3732 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
3733 tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
3735 gfc_add_expr_to_block (&loop.pre, tmp);
3737 else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
3739 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
3741 gfc_add_modify (&loop.pre, limit, tmp);
3744 /* For a scalar mask, enclose the loop in an if statement. */
3745 if (maskexpr && maskss == NULL)
3749 gfc_init_se (&maskse, NULL);
3750 gfc_conv_expr_val (&maskse, maskexpr);
3751 gfc_init_block (&block);
3752 gfc_add_block_to_block (&block, &loop.pre);
3753 gfc_add_block_to_block (&block, &loop.post);
3754 tmp = gfc_finish_block (&block);
3756 if (HONOR_INFINITIES (DECL_MODE (limit)))
3757 else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
3759 else_stmt = build_empty_stmt (input_location);
3760 tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
3761 gfc_add_expr_to_block (&block, tmp);
3762 gfc_add_block_to_block (&se->pre, &block);
3766 gfc_add_block_to_block (&se->pre, &loop.pre);
3767 gfc_add_block_to_block (&se->pre, &loop.post);
3770 gfc_cleanup_loop (&loop);
3775 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3777 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
3783 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3784 type = TREE_TYPE (args[0]);
3786 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3787 build_int_cst (type, 1), args[1]);
3788 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
3789 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
3790 build_int_cst (type, 0));
3791 type = gfc_typenode_for_spec (&expr->ts);
3792 se->expr = convert (type, tmp);
3796 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
3798 gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
3802 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3804 /* Convert both arguments to the unsigned type of the same size. */
3805 args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
3806 args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
3808 /* If they have unequal type size, convert to the larger one. */
3809 if (TYPE_PRECISION (TREE_TYPE (args[0]))
3810 > TYPE_PRECISION (TREE_TYPE (args[1])))
3811 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
3812 else if (TYPE_PRECISION (TREE_TYPE (args[1]))
3813 > TYPE_PRECISION (TREE_TYPE (args[0])))
3814 args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
3816 /* Now, we compare them. */
3817 se->expr = fold_build2_loc (input_location, op, boolean_type_node,
3822 /* Generate code to perform the specified operation. */
3824 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
3828 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3829 se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
3835 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
3839 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3840 se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
3841 TREE_TYPE (arg), arg);
3844 /* Set or clear a single bit. */
3846 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
3853 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3854 type = TREE_TYPE (args[0]);
3856 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3857 build_int_cst (type, 1), args[1]);
3863 tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
3865 se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
3868 /* Extract a sequence of bits.
3869 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3871 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
3878 gfc_conv_intrinsic_function_args (se, expr, args, 3);
3879 type = TREE_TYPE (args[0]);
3881 mask = build_int_cst (type, -1);
3882 mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
3883 mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
3885 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
3887 se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
3891 gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
3894 tree args[2], type, num_bits, cond;
3896 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3898 args[0] = gfc_evaluate_now (args[0], &se->pre);
3899 args[1] = gfc_evaluate_now (args[1], &se->pre);
3900 type = TREE_TYPE (args[0]);
3903 args[0] = fold_convert (unsigned_type_for (type), args[0]);
3905 gcc_assert (right_shift);
3907 se->expr = fold_build2_loc (input_location,
3908 right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
3909 TREE_TYPE (args[0]), args[0], args[1]);
3912 se->expr = fold_convert (type, se->expr);
3914 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3915 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3917 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
3918 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3921 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
3922 build_int_cst (type, 0), se->expr);
3925 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
3927 : ((shift >= 0) ? i << shift : i >> -shift)
3928 where all shifts are logical shifts. */
3930 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
3942 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3944 args[0] = gfc_evaluate_now (args[0], &se->pre);
3945 args[1] = gfc_evaluate_now (args[1], &se->pre);
3947 type = TREE_TYPE (args[0]);
3948 utype = unsigned_type_for (type);
3950 width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
3953 /* Left shift if positive. */
3954 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
3956 /* Right shift if negative.
3957 We convert to an unsigned type because we want a logical shift.
3958 The standard doesn't define the case of shifting negative
3959 numbers, and we try to be compatible with other compilers, most
3960 notably g77, here. */
3961 rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
3962 utype, convert (utype, args[0]), width));
3964 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, args[1],
3965 build_int_cst (TREE_TYPE (args[1]), 0));
3966 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
3968 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3969 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3971 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
3972 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, width,
3974 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
3975 build_int_cst (type, 0), tmp);
3979 /* Circular shift. AKA rotate or barrel shift. */
3982 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
3990 unsigned int num_args;
3992 num_args = gfc_intrinsic_argument_list_length (expr);
3993 args = XALLOCAVEC (tree, num_args);
3995 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3999 /* Use a library function for the 3 parameter version. */
4000 tree int4type = gfc_get_int_type (4);
4002 type = TREE_TYPE (args[0]);
4003 /* We convert the first argument to at least 4 bytes, and
4004 convert back afterwards. This removes the need for library
4005 functions for all argument sizes, and function will be
4006 aligned to at least 32 bits, so there's no loss. */
4007 if (expr->ts.kind < 4)
4008 args[0] = convert (int4type, args[0]);
4010 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4011 need loads of library functions. They cannot have values >
4012 BIT_SIZE (I) so the conversion is safe. */
4013 args[1] = convert (int4type, args[1]);
4014 args[2] = convert (int4type, args[2]);
4016 switch (expr->ts.kind)
4021 tmp = gfor_fndecl_math_ishftc4;
4024 tmp = gfor_fndecl_math_ishftc8;
4027 tmp = gfor_fndecl_math_ishftc16;
4032 se->expr = build_call_expr_loc (input_location,
4033 tmp, 3, args[0], args[1], args[2]);
4034 /* Convert the result back to the original type, if we extended
4035 the first argument's width above. */
4036 if (expr->ts.kind < 4)
4037 se->expr = convert (type, se->expr);
4041 type = TREE_TYPE (args[0]);
4043 /* Evaluate arguments only once. */
4044 args[0] = gfc_evaluate_now (args[0], &se->pre);
4045 args[1] = gfc_evaluate_now (args[1], &se->pre);
4047 /* Rotate left if positive. */
4048 lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
4050 /* Rotate right if negative. */
4051 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
4053 rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
4055 zero = build_int_cst (TREE_TYPE (args[1]), 0);
4056 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, args[1],
4058 rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
4060 /* Do nothing if shift == 0. */
4061 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, args[1],
4063 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
4068 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4069 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4071 The conditional expression is necessary because the result of LEADZ(0)
4072 is defined, but the result of __builtin_clz(0) is undefined for most
4075 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4076 difference in bit size between the argument of LEADZ and the C int. */
4079 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
4091 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4092 argsize = TYPE_PRECISION (TREE_TYPE (arg));
4094 /* Which variant of __builtin_clz* should we call? */
4095 if (argsize <= INT_TYPE_SIZE)
4097 arg_type = unsigned_type_node;
4098 func = builtin_decl_explicit (BUILT_IN_CLZ);
4100 else if (argsize <= LONG_TYPE_SIZE)
4102 arg_type = long_unsigned_type_node;
4103 func = builtin_decl_explicit (BUILT_IN_CLZL);
4105 else if (argsize <= LONG_LONG_TYPE_SIZE)
4107 arg_type = long_long_unsigned_type_node;
4108 func = builtin_decl_explicit (BUILT_IN_CLZLL);
4112 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
4113 arg_type = gfc_build_uint_type (argsize);
4117 /* Convert the actual argument twice: first, to the unsigned type of the
4118 same size; then, to the proper argument type for the built-in
4119 function. But the return type is of the default INTEGER kind. */
4120 arg = fold_convert (gfc_build_uint_type (argsize), arg);
4121 arg = fold_convert (arg_type, arg);
4122 arg = gfc_evaluate_now (arg, &se->pre);
4123 result_type = gfc_get_int_type (gfc_default_integer_kind);
4125 /* Compute LEADZ for the case i .ne. 0. */
4128 s = TYPE_PRECISION (arg_type) - argsize;
4129 tmp = fold_convert (result_type,
4130 build_call_expr_loc (input_location, func,
4132 leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
4133 tmp, build_int_cst (result_type, s));
4137 /* We end up here if the argument type is larger than 'long long'.
4138 We generate this code:
4140 if (x & (ULL_MAX << ULL_SIZE) != 0)
4141 return clzll ((unsigned long long) (x >> ULLSIZE));
4143 return ULL_SIZE + clzll ((unsigned long long) x);
4144 where ULL_MAX is the largest value that a ULL_MAX can hold
4145 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4146 is the bit-size of the long long type (64 in this example). */
4147 tree ullsize, ullmax, tmp1, tmp2, btmp;
4149 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
4150 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
4151 long_long_unsigned_type_node,
4152 build_int_cst (long_long_unsigned_type_node,
4155 cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
4156 fold_convert (arg_type, ullmax), ullsize);
4157 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
4159 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4160 cond, build_int_cst (arg_type, 0));
4162 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
4164 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
4165 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
4166 tmp1 = fold_convert (result_type,
4167 build_call_expr_loc (input_location, btmp, 1, tmp1));
4169 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
4170 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
4171 tmp2 = fold_convert (result_type,
4172 build_call_expr_loc (input_location, btmp, 1, tmp2));
4173 tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
4176 leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
4180 /* Build BIT_SIZE. */
4181 bit_size = build_int_cst (result_type, argsize);
4183 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4184 arg, build_int_cst (arg_type, 0));
4185 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
4190 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4192 The conditional expression is necessary because the result of TRAILZ(0)
4193 is defined, but the result of __builtin_ctz(0) is undefined for most
4197 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
4208 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4209 argsize = TYPE_PRECISION (TREE_TYPE (arg));
4211 /* Which variant of __builtin_ctz* should we call? */
4212 if (argsize <= INT_TYPE_SIZE)
4214 arg_type = unsigned_type_node;
4215 func = builtin_decl_explicit (BUILT_IN_CTZ);
4217 else if (argsize <= LONG_TYPE_SIZE)
4219 arg_type = long_unsigned_type_node;
4220 func = builtin_decl_explicit (BUILT_IN_CTZL);
4222 else if (argsize <= LONG_LONG_TYPE_SIZE)
4224 arg_type = long_long_unsigned_type_node;
4225 func = builtin_decl_explicit (BUILT_IN_CTZLL);
4229 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
4230 arg_type = gfc_build_uint_type (argsize);
4234 /* Convert the actual argument twice: first, to the unsigned type of the
4235 same size; then, to the proper argument type for the built-in
4236 function. But the return type is of the default INTEGER kind. */
4237 arg = fold_convert (gfc_build_uint_type (argsize), arg);
4238 arg = fold_convert (arg_type, arg);
4239 arg = gfc_evaluate_now (arg, &se->pre);
4240 result_type = gfc_get_int_type (gfc_default_integer_kind);
4242 /* Compute TRAILZ for the case i .ne. 0. */
4244 trailz = fold_convert (result_type, build_call_expr_loc (input_location,
4248 /* We end up here if the argument type is larger than 'long long'.
4249 We generate this code:
4251 if ((x & ULL_MAX) == 0)
4252 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
4254 return ctzll ((unsigned long long) x);
4256 where ULL_MAX is the largest value that a ULL_MAX can hold
4257 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4258 is the bit-size of the long long type (64 in this example). */
4259 tree ullsize, ullmax, tmp1, tmp2, btmp;
4261 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
4262 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
4263 long_long_unsigned_type_node,
4264 build_int_cst (long_long_unsigned_type_node, 0));
4266 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
4267 fold_convert (arg_type, ullmax));
4268 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, cond,
4269 build_int_cst (arg_type, 0));
4271 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
4273 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
4274 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
4275 tmp1 = fold_convert (result_type,
4276 build_call_expr_loc (input_location, btmp, 1, tmp1));
4277 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
4280 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
4281 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
4282 tmp2 = fold_convert (result_type,
4283 build_call_expr_loc (input_location, btmp, 1, tmp2));
4285 trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
4289 /* Build BIT_SIZE. */
4290 bit_size = build_int_cst (result_type, argsize);
4292 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4293 arg, build_int_cst (arg_type, 0));
4294 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
4298 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
4299 for types larger than "long long", we call the long long built-in for
4300 the lower and higher bits and combine the result. */
4303 gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
4311 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4312 argsize = TYPE_PRECISION (TREE_TYPE (arg));
4313 result_type = gfc_get_int_type (gfc_default_integer_kind);
4315 /* Which variant of the builtin should we call? */
4316 if (argsize <= INT_TYPE_SIZE)
4318 arg_type = unsigned_type_node;
4319 func = builtin_decl_explicit (parity
4321 : BUILT_IN_POPCOUNT);
4323 else if (argsize <= LONG_TYPE_SIZE)
4325 arg_type = long_unsigned_type_node;
4326 func = builtin_decl_explicit (parity
4328 : BUILT_IN_POPCOUNTL);
4330 else if (argsize <= LONG_LONG_TYPE_SIZE)
4332 arg_type = long_long_unsigned_type_node;
4333 func = builtin_decl_explicit (parity
4335 : BUILT_IN_POPCOUNTLL);
4339 /* Our argument type is larger than 'long long', which mean none
4340 of the POPCOUNT builtins covers it. We thus call the 'long long'
4341 variant multiple times, and add the results. */
4342 tree utype, arg2, call1, call2;
4344 /* For now, we only cover the case where argsize is twice as large
4346 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
4348 func = builtin_decl_explicit (parity
4350 : BUILT_IN_POPCOUNTLL);
4352 /* Convert it to an integer, and store into a variable. */
4353 utype = gfc_build_uint_type (argsize);
4354 arg = fold_convert (utype, arg);
4355 arg = gfc_evaluate_now (arg, &se->pre);
4357 /* Call the builtin twice. */
4358 call1 = build_call_expr_loc (input_location, func, 1,
4359 fold_convert (long_long_unsigned_type_node,
4362 arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
4363 build_int_cst (utype, LONG_LONG_TYPE_SIZE));
4364 call2 = build_call_expr_loc (input_location, func, 1,
4365 fold_convert (long_long_unsigned_type_node,
4368 /* Combine the results. */
4370 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type,
4373 se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type,
4379 /* Convert the actual argument twice: first, to the unsigned type of the
4380 same size; then, to the proper argument type for the built-in
4382 arg = fold_convert (gfc_build_uint_type (argsize), arg);
4383 arg = fold_convert (arg_type, arg);
4385 se->expr = fold_convert (result_type,
4386 build_call_expr_loc (input_location, func, 1, arg));
4390 /* Process an intrinsic with unspecified argument-types that has an optional
4391 argument (which could be of type character), e.g. EOSHIFT. For those, we
4392 need to append the string length of the optional argument if it is not
4393 present and the type is really character.
4394 primary specifies the position (starting at 1) of the non-optional argument
4395 specifying the type and optional gives the position of the optional
4396 argument in the arglist. */
4399 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
4400 unsigned primary, unsigned optional)
4402 gfc_actual_arglist* prim_arg;
4403 gfc_actual_arglist* opt_arg;
4405 gfc_actual_arglist* arg;
4407 VEC(tree,gc) *append_args;
4409 /* Find the two arguments given as position. */
4413 for (arg = expr->value.function.actual; arg; arg = arg->next)
4417 if (cur_pos == primary)
4419 if (cur_pos == optional)
4422 if (cur_pos >= primary && cur_pos >= optional)
4425 gcc_assert (prim_arg);
4426 gcc_assert (prim_arg->expr);
4427 gcc_assert (opt_arg);
4429 /* If we do have type CHARACTER and the optional argument is really absent,
4430 append a dummy 0 as string length. */
4432 if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
4436 dummy = build_int_cst (gfc_charlen_type_node, 0);
4437 append_args = VEC_alloc (tree, gc, 1);
4438 VEC_quick_push (tree, append_args, dummy);
4441 /* Build the call itself. */
4442 sym = gfc_get_symbol_for_expr (expr);
4443 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4449 /* The length of a character string. */
4451 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
4461 gcc_assert (!se->ss);
4463 arg = expr->value.function.actual->expr;
4465 type = gfc_typenode_for_spec (&expr->ts);
4466 switch (arg->expr_type)
4469 len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
4473 /* Obtain the string length from the function used by
4474 trans-array.c(gfc_trans_array_constructor). */
4476 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
4480 if (arg->ref == NULL
4481 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
4483 /* This doesn't catch all cases.
4484 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
4485 and the surrounding thread. */
4486 sym = arg->symtree->n.sym;
4487 decl = gfc_get_symbol_decl (sym);
4488 if (decl == current_function_decl && sym->attr.function
4489 && (sym->result == sym))
4490 decl = gfc_get_fake_result_decl (sym, 0);
4492 len = sym->ts.u.cl->backend_decl;
4497 /* Otherwise fall through. */
4500 /* Anybody stupid enough to do this deserves inefficient code. */
4501 ss = gfc_walk_expr (arg);
4502 gfc_init_se (&argse, se);
4503 if (ss == gfc_ss_terminator)
4504 gfc_conv_expr (&argse, arg);
4506 gfc_conv_expr_descriptor (&argse, arg, ss);
4507 gfc_add_block_to_block (&se->pre, &argse.pre);
4508 gfc_add_block_to_block (&se->post, &argse.post);
4509 len = argse.string_length;
4512 se->expr = convert (type, len);
4515 /* The length of a character string not including trailing blanks. */
4517 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
4519 int kind = expr->value.function.actual->expr->ts.kind;
4520 tree args[2], type, fndecl;
4522 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4523 type = gfc_typenode_for_spec (&expr->ts);
4526 fndecl = gfor_fndecl_string_len_trim;
4528 fndecl = gfor_fndecl_string_len_trim_char4;
4532 se->expr = build_call_expr_loc (input_location,
4533 fndecl, 2, args[0], args[1]);
4534 se->expr = convert (type, se->expr);
4538 /* Returns the starting position of a substring within a string. */
4541 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
4544 tree logical4_type_node = gfc_get_logical_type (4);
4548 unsigned int num_args;
4550 args = XALLOCAVEC (tree, 5);
4552 /* Get number of arguments; characters count double due to the
4553 string length argument. Kind= is not passed to the library
4554 and thus ignored. */
4555 if (expr->value.function.actual->next->next->expr == NULL)
4560 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
4561 type = gfc_typenode_for_spec (&expr->ts);
4564 args[4] = build_int_cst (logical4_type_node, 0);
4566 args[4] = convert (logical4_type_node, args[4]);
4568 fndecl = build_addr (function, current_function_decl);
4569 se->expr = build_call_array_loc (input_location,
4570 TREE_TYPE (TREE_TYPE (function)), fndecl,
4572 se->expr = convert (type, se->expr);
4576 /* The ascii value for a single character. */
4578 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
4580 tree args[2], type, pchartype;
4582 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4583 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
4584 pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
4585 args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
4586 type = gfc_typenode_for_spec (&expr->ts);
4588 se->expr = build_fold_indirect_ref_loc (input_location,
4590 se->expr = convert (type, se->expr);
4594 /* Intrinsic ISNAN calls __builtin_isnan. */
4597 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
4601 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4602 se->expr = build_call_expr_loc (input_location,
4603 builtin_decl_explicit (BUILT_IN_ISNAN),
4605 STRIP_TYPE_NOPS (se->expr);
4606 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4610 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
4611 their argument against a constant integer value. */
4614 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
4618 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4619 se->expr = fold_build2_loc (input_location, EQ_EXPR,
4620 gfc_typenode_for_spec (&expr->ts),
4621 arg, build_int_cst (TREE_TYPE (arg), value));
4626 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
4629 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
4637 unsigned int num_args;
4639 num_args = gfc_intrinsic_argument_list_length (expr);
4640 args = XALLOCAVEC (tree, num_args);
4642 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
4643 if (expr->ts.type != BT_CHARACTER)
4651 /* We do the same as in the non-character case, but the argument
4652 list is different because of the string length arguments. We
4653 also have to set the string length for the result. */
4660 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
4662 se->string_length = len;
4664 type = TREE_TYPE (tsource);
4665 se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
4666 fold_convert (type, fsource));
4670 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
4673 gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
4675 tree args[3], mask, type;
4677 gfc_conv_intrinsic_function_args (se, expr, args, 3);
4678 mask = gfc_evaluate_now (args[2], &se->pre);
4680 type = TREE_TYPE (args[0]);
4681 gcc_assert (TREE_TYPE (args[1]) == type);
4682 gcc_assert (TREE_TYPE (mask) == type);
4684 args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
4685 args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
4686 fold_build1_loc (input_location, BIT_NOT_EXPR,
4688 se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
4693 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
4694 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
4697 gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
4699 tree arg, allones, type, utype, res, cond, bitsize;
4702 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4703 arg = gfc_evaluate_now (arg, &se->pre);
4705 type = gfc_get_int_type (expr->ts.kind);
4706 utype = unsigned_type_for (type);
4708 i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
4709 bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
4711 allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
4712 build_int_cst (utype, 0));
4716 /* Left-justified mask. */
4717 res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
4719 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
4720 fold_convert (utype, res));
4722 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
4723 smaller than type width. */
4724 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
4725 build_int_cst (TREE_TYPE (arg), 0));
4726 res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
4727 build_int_cst (utype, 0), res);
4731 /* Right-justified mask. */
4732 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
4733 fold_convert (utype, arg));
4734 res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
4736 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
4737 strictly smaller than type width. */
4738 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4740 res = fold_build3_loc (input_location, COND_EXPR, utype,
4741 cond, allones, res);
4744 se->expr = fold_convert (type, res);
4748 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
4750 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
4752 tree arg, type, tmp, frexp;
4754 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4756 type = gfc_typenode_for_spec (&expr->ts);
4757 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4758 tmp = gfc_create_var (integer_type_node, NULL);
4759 se->expr = build_call_expr_loc (input_location, frexp, 2,
4760 fold_convert (type, arg),
4761 gfc_build_addr_expr (NULL_TREE, tmp));
4762 se->expr = fold_convert (type, se->expr);
4766 /* NEAREST (s, dir) is translated into
4767 tmp = copysign (HUGE_VAL, dir);
4768 return nextafter (s, tmp);
4771 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
4773 tree args[2], type, tmp, nextafter, copysign, huge_val;
4775 nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
4776 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
4778 type = gfc_typenode_for_spec (&expr->ts);
4779 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4781 huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
4782 tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
4783 fold_convert (type, args[1]));
4784 se->expr = build_call_expr_loc (input_location, nextafter, 2,
4785 fold_convert (type, args[0]), tmp);
4786 se->expr = fold_convert (type, se->expr);
4790 /* SPACING (s) is translated into
4798 e = MAX_EXPR (e, emin);
4799 res = scalbn (1., e);
4803 where prec is the precision of s, gfc_real_kinds[k].digits,
4804 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
4805 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
4808 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
4810 tree arg, type, prec, emin, tiny, res, e;
4811 tree cond, tmp, frexp, scalbn;
4815 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
4816 prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
4817 emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
4818 tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
4820 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4821 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4823 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4824 arg = gfc_evaluate_now (arg, &se->pre);
4826 type = gfc_typenode_for_spec (&expr->ts);
4827 e = gfc_create_var (integer_type_node, NULL);
4828 res = gfc_create_var (type, NULL);
4831 /* Build the block for s /= 0. */
4832 gfc_start_block (&block);
4833 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
4834 gfc_build_addr_expr (NULL_TREE, e));
4835 gfc_add_expr_to_block (&block, tmp);
4837 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
4839 gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
4840 integer_type_node, tmp, emin));
4842 tmp = build_call_expr_loc (input_location, scalbn, 2,
4843 build_real_from_int_cst (type, integer_one_node), e);
4844 gfc_add_modify (&block, res, tmp);
4846 /* Finish by building the IF statement. */
4847 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
4848 build_real_from_int_cst (type, integer_zero_node));
4849 tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
4850 gfc_finish_block (&block));
4852 gfc_add_expr_to_block (&se->pre, tmp);
4857 /* RRSPACING (s) is translated into
4864 x = scalbn (x, precision - e);
4868 where precision is gfc_real_kinds[k].digits. */
4871 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
4873 tree arg, type, e, x, cond, stmt, tmp, frexp, scalbn, fabs;
4877 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
4878 prec = gfc_real_kinds[k].digits;
4880 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4881 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4882 fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
4884 type = gfc_typenode_for_spec (&expr->ts);
4885 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4886 arg = gfc_evaluate_now (arg, &se->pre);
4888 e = gfc_create_var (integer_type_node, NULL);
4889 x = gfc_create_var (type, NULL);
4890 gfc_add_modify (&se->pre, x,
4891 build_call_expr_loc (input_location, fabs, 1, arg));
4894 gfc_start_block (&block);
4895 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
4896 gfc_build_addr_expr (NULL_TREE, e));
4897 gfc_add_expr_to_block (&block, tmp);
4899 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4900 build_int_cst (integer_type_node, prec), e);
4901 tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
4902 gfc_add_modify (&block, x, tmp);
4903 stmt = gfc_finish_block (&block);
4905 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, x,
4906 build_real_from_int_cst (type, integer_zero_node));
4907 tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
4908 gfc_add_expr_to_block (&se->pre, tmp);
4910 se->expr = fold_convert (type, x);
4914 /* SCALE (s, i) is translated into scalbn (s, i). */
4916 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
4918 tree args[2], type, scalbn;
4920 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4922 type = gfc_typenode_for_spec (&expr->ts);
4923 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4924 se->expr = build_call_expr_loc (input_location, scalbn, 2,
4925 fold_convert (type, args[0]),
4926 fold_convert (integer_type_node, args[1]));
4927 se->expr = fold_convert (type, se->expr);
4931 /* SET_EXPONENT (s, i) is translated into
4932 scalbn (frexp (s, &dummy_int), i). */
4934 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
4936 tree args[2], type, tmp, frexp, scalbn;
4938 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4939 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4941 type = gfc_typenode_for_spec (&expr->ts);
4942 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4944 tmp = gfc_create_var (integer_type_node, NULL);
4945 tmp = build_call_expr_loc (input_location, frexp, 2,
4946 fold_convert (type, args[0]),
4947 gfc_build_addr_expr (NULL_TREE, tmp));
4948 se->expr = build_call_expr_loc (input_location, scalbn, 2, tmp,
4949 fold_convert (integer_type_node, args[1]));
4950 se->expr = fold_convert (type, se->expr);
4955 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
4957 gfc_actual_arglist *actual;
4965 gfc_init_se (&argse, NULL);
4966 actual = expr->value.function.actual;
4968 ss = gfc_walk_expr (actual->expr);
4969 gcc_assert (ss != gfc_ss_terminator);
4970 argse.want_pointer = 1;
4971 argse.data_not_needed = 1;
4972 gfc_conv_expr_descriptor (&argse, actual->expr, ss);
4973 gfc_add_block_to_block (&se->pre, &argse.pre);
4974 gfc_add_block_to_block (&se->post, &argse.post);
4975 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
4977 /* Build the call to size0. */
4978 fncall0 = build_call_expr_loc (input_location,
4979 gfor_fndecl_size0, 1, arg1);
4981 actual = actual->next;
4985 gfc_init_se (&argse, NULL);
4986 gfc_conv_expr_type (&argse, actual->expr,
4987 gfc_array_index_type);
4988 gfc_add_block_to_block (&se->pre, &argse.pre);
4990 /* Unusually, for an intrinsic, size does not exclude
4991 an optional arg2, so we must test for it. */
4992 if (actual->expr->expr_type == EXPR_VARIABLE
4993 && actual->expr->symtree->n.sym->attr.dummy
4994 && actual->expr->symtree->n.sym->attr.optional)
4997 /* Build the call to size1. */
4998 fncall1 = build_call_expr_loc (input_location,
4999 gfor_fndecl_size1, 2,
5002 gfc_init_se (&argse, NULL);
5003 argse.want_pointer = 1;
5004 argse.data_not_needed = 1;
5005 gfc_conv_expr (&argse, actual->expr);
5006 gfc_add_block_to_block (&se->pre, &argse.pre);
5007 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5008 argse.expr, null_pointer_node);
5009 tmp = gfc_evaluate_now (tmp, &se->pre);
5010 se->expr = fold_build3_loc (input_location, COND_EXPR,
5011 pvoid_type_node, tmp, fncall1, fncall0);
5015 se->expr = NULL_TREE;
5016 argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
5017 gfc_array_index_type,
5018 argse.expr, gfc_index_one_node);
5021 else if (expr->value.function.actual->expr->rank == 1)
5023 argse.expr = gfc_index_zero_node;
5024 se->expr = NULL_TREE;
5029 if (se->expr == NULL_TREE)
5031 tree ubound, lbound;
5033 arg1 = build_fold_indirect_ref_loc (input_location,
5035 ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
5036 lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
5037 se->expr = fold_build2_loc (input_location, MINUS_EXPR,
5038 gfc_array_index_type, ubound, lbound);
5039 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
5040 gfc_array_index_type,
5041 se->expr, gfc_index_one_node);
5042 se->expr = fold_build2_loc (input_location, MAX_EXPR,
5043 gfc_array_index_type, se->expr,
5044 gfc_index_zero_node);
5047 type = gfc_typenode_for_spec (&expr->ts);
5048 se->expr = convert (type, se->expr);
5052 /* Helper function to compute the size of a character variable,
5053 excluding the terminating null characters. The result has
5054 gfc_array_index_type type. */
5057 size_of_string_in_bytes (int kind, tree string_length)
5060 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
5062 bytesize = build_int_cst (gfc_array_index_type,
5063 gfc_character_kinds[i].bit_size / 8);
5065 return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5067 fold_convert (gfc_array_index_type, string_length));
5072 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
5084 arg = expr->value.function.actual->expr;
5086 gfc_init_se (&argse, NULL);
5087 ss = gfc_walk_expr (arg);
5089 if (ss == gfc_ss_terminator)
5091 if (arg->ts.type == BT_CLASS)
5092 gfc_add_data_component (arg);
5094 gfc_conv_expr_reference (&argse, arg);
5096 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5099 /* Obtain the source word length. */
5100 if (arg->ts.type == BT_CHARACTER)
5101 se->expr = size_of_string_in_bytes (arg->ts.kind,
5102 argse.string_length);
5104 se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
5108 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
5109 argse.want_pointer = 0;
5110 gfc_conv_expr_descriptor (&argse, arg, ss);
5111 type = gfc_get_element_type (TREE_TYPE (argse.expr));
5113 /* Obtain the argument's word length. */
5114 if (arg->ts.type == BT_CHARACTER)
5115 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
5117 tmp = fold_convert (gfc_array_index_type,
5118 size_in_bytes (type));
5119 gfc_add_modify (&argse.pre, source_bytes, tmp);
5121 /* Obtain the size of the array in bytes. */
5122 for (n = 0; n < arg->rank; n++)
5125 idx = gfc_rank_cst[n];
5126 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
5127 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
5128 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5129 gfc_array_index_type, upper, lower);
5130 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5131 gfc_array_index_type, tmp, gfc_index_one_node);
5132 tmp = fold_build2_loc (input_location, MULT_EXPR,
5133 gfc_array_index_type, tmp, source_bytes);
5134 gfc_add_modify (&argse.pre, source_bytes, tmp);
5136 se->expr = source_bytes;
5139 gfc_add_block_to_block (&se->pre, &argse.pre);
5144 gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
5149 tree type, result_type, tmp;
5151 arg = expr->value.function.actual->expr;
5152 gfc_init_se (&eight, NULL);
5153 gfc_conv_expr (&eight, gfc_get_int_expr (expr->ts.kind, NULL, 8));
5155 gfc_init_se (&argse, NULL);
5156 ss = gfc_walk_expr (arg);
5157 result_type = gfc_get_int_type (expr->ts.kind);
5159 if (ss == gfc_ss_terminator)
5161 if (arg->ts.type == BT_CLASS)
5163 gfc_add_vptr_component (arg);
5164 gfc_add_size_component (arg);
5165 gfc_conv_expr (&argse, arg);
5166 tmp = fold_convert (result_type, argse.expr);
5170 gfc_conv_expr_reference (&argse, arg);
5171 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5176 argse.want_pointer = 0;
5177 gfc_conv_expr_descriptor (&argse, arg, ss);
5178 type = gfc_get_element_type (TREE_TYPE (argse.expr));
5181 /* Obtain the argument's word length. */
5182 if (arg->ts.type == BT_CHARACTER)
5183 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
5185 tmp = fold_convert (result_type, size_in_bytes (type));
5188 se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
5190 gfc_add_block_to_block (&se->pre, &argse.pre);
5194 /* Intrinsic string comparison functions. */
5197 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
5201 gfc_conv_intrinsic_function_args (se, expr, args, 4);
5204 = gfc_build_compare_string (args[0], args[1], args[2], args[3],
5205 expr->value.function.actual->expr->ts.kind,
5207 se->expr = fold_build2_loc (input_location, op,
5208 gfc_typenode_for_spec (&expr->ts), se->expr,
5209 build_int_cst (TREE_TYPE (se->expr), 0));
5212 /* Generate a call to the adjustl/adjustr library function. */
5214 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
5222 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
5225 type = TREE_TYPE (args[2]);
5226 var = gfc_conv_string_tmp (se, type, len);
5229 tmp = build_call_expr_loc (input_location,
5230 fndecl, 3, args[0], args[1], args[2]);
5231 gfc_add_expr_to_block (&se->pre, tmp);
5233 se->string_length = len;
5237 /* Generate code for the TRANSFER intrinsic:
5239 DEST = TRANSFER (SOURCE, MOLD)
5241 typeof<DEST> = typeof<MOLD>
5246 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
5248 typeof<DEST> = typeof<MOLD>
5250 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
5251 sizeof (DEST(0) * SIZE). */
5253 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
5269 gfc_actual_arglist *arg;
5272 gfc_array_info *info;
5279 info = &se->ss->data.info;
5281 /* Convert SOURCE. The output from this stage is:-
5282 source_bytes = length of the source in bytes
5283 source = pointer to the source data. */
5284 arg = expr->value.function.actual;
5286 /* Ensure double transfer through LOGICAL preserves all
5288 if (arg->expr->expr_type == EXPR_FUNCTION
5289 && arg->expr->value.function.esym == NULL
5290 && arg->expr->value.function.isym != NULL
5291 && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
5292 && arg->expr->ts.type == BT_LOGICAL
5293 && expr->ts.type != arg->expr->ts.type)
5294 arg->expr->value.function.name = "__transfer_in_transfer";
5296 gfc_init_se (&argse, NULL);
5297 ss = gfc_walk_expr (arg->expr);
5299 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
5301 /* Obtain the pointer to source and the length of source in bytes. */
5302 if (ss == gfc_ss_terminator)
5304 gfc_conv_expr_reference (&argse, arg->expr);
5305 source = argse.expr;
5307 source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5310 /* Obtain the source word length. */
5311 if (arg->expr->ts.type == BT_CHARACTER)
5312 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
5313 argse.string_length);
5315 tmp = fold_convert (gfc_array_index_type,
5316 size_in_bytes (source_type));
5320 argse.want_pointer = 0;
5321 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
5322 source = gfc_conv_descriptor_data_get (argse.expr);
5323 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
5325 /* Repack the source if not a full variable array. */
5326 if (arg->expr->expr_type == EXPR_VARIABLE
5327 && arg->expr->ref->u.ar.type != AR_FULL)
5329 tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
5331 if (gfc_option.warn_array_temp)
5332 gfc_warning ("Creating array temporary at %L", &expr->where);
5334 source = build_call_expr_loc (input_location,
5335 gfor_fndecl_in_pack, 1, tmp);
5336 source = gfc_evaluate_now (source, &argse.pre);
5338 /* Free the temporary. */
5339 gfc_start_block (&block);
5340 tmp = gfc_call_free (convert (pvoid_type_node, source));
5341 gfc_add_expr_to_block (&block, tmp);
5342 stmt = gfc_finish_block (&block);
5344 /* Clean up if it was repacked. */
5345 gfc_init_block (&block);
5346 tmp = gfc_conv_array_data (argse.expr);
5347 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5349 tmp = build3_v (COND_EXPR, tmp, stmt,
5350 build_empty_stmt (input_location));
5351 gfc_add_expr_to_block (&block, tmp);
5352 gfc_add_block_to_block (&block, &se->post);
5353 gfc_init_block (&se->post);
5354 gfc_add_block_to_block (&se->post, &block);
5357 /* Obtain the source word length. */
5358 if (arg->expr->ts.type == BT_CHARACTER)
5359 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
5360 argse.string_length);
5362 tmp = fold_convert (gfc_array_index_type,
5363 size_in_bytes (source_type));
5365 /* Obtain the size of the array in bytes. */
5366 extent = gfc_create_var (gfc_array_index_type, NULL);
5367 for (n = 0; n < arg->expr->rank; n++)
5370 idx = gfc_rank_cst[n];
5371 gfc_add_modify (&argse.pre, source_bytes, tmp);
5372 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
5373 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
5374 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5375 gfc_array_index_type, upper, lower);
5376 gfc_add_modify (&argse.pre, extent, tmp);
5377 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5378 gfc_array_index_type, extent,
5379 gfc_index_one_node);
5380 tmp = fold_build2_loc (input_location, MULT_EXPR,
5381 gfc_array_index_type, tmp, source_bytes);
5385 gfc_add_modify (&argse.pre, source_bytes, tmp);
5386 gfc_add_block_to_block (&se->pre, &argse.pre);
5387 gfc_add_block_to_block (&se->post, &argse.post);
5389 /* Now convert MOLD. The outputs are:
5390 mold_type = the TREE type of MOLD
5391 dest_word_len = destination word length in bytes. */
5394 gfc_init_se (&argse, NULL);
5395 ss = gfc_walk_expr (arg->expr);
5397 scalar_mold = arg->expr->rank == 0;
5399 if (ss == gfc_ss_terminator)
5401 gfc_conv_expr_reference (&argse, arg->expr);
5402 mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5407 gfc_init_se (&argse, NULL);
5408 argse.want_pointer = 0;
5409 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
5410 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
5413 gfc_add_block_to_block (&se->pre, &argse.pre);
5414 gfc_add_block_to_block (&se->post, &argse.post);
5416 if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
5418 /* If this TRANSFER is nested in another TRANSFER, use a type
5419 that preserves all bits. */
5420 if (arg->expr->ts.type == BT_LOGICAL)
5421 mold_type = gfc_get_int_type (arg->expr->ts.kind);
5424 if (arg->expr->ts.type == BT_CHARACTER)
5426 tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
5427 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
5430 tmp = fold_convert (gfc_array_index_type,
5431 size_in_bytes (mold_type));
5433 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
5434 gfc_add_modify (&se->pre, dest_word_len, tmp);
5436 /* Finally convert SIZE, if it is present. */
5438 size_words = gfc_create_var (gfc_array_index_type, NULL);
5442 gfc_init_se (&argse, NULL);
5443 gfc_conv_expr_reference (&argse, arg->expr);
5444 tmp = convert (gfc_array_index_type,
5445 build_fold_indirect_ref_loc (input_location,
5447 gfc_add_block_to_block (&se->pre, &argse.pre);
5448 gfc_add_block_to_block (&se->post, &argse.post);
5453 /* Separate array and scalar results. */
5454 if (scalar_mold && tmp == NULL_TREE)
5455 goto scalar_transfer;
5457 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
5458 if (tmp != NULL_TREE)
5459 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5460 tmp, dest_word_len);
5464 gfc_add_modify (&se->pre, size_bytes, tmp);
5465 gfc_add_modify (&se->pre, size_words,
5466 fold_build2_loc (input_location, CEIL_DIV_EXPR,
5467 gfc_array_index_type,
5468 size_bytes, dest_word_len));
5470 /* Evaluate the bounds of the result. If the loop range exists, we have
5471 to check if it is too large. If so, we modify loop->to be consistent
5472 with min(size, size(source)). Otherwise, size is made consistent with
5473 the loop range, so that the right number of bytes is transferred.*/
5474 n = se->loop->order[0];
5475 if (se->loop->to[n] != NULL_TREE)
5477 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5478 se->loop->to[n], se->loop->from[n]);
5479 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5480 tmp, gfc_index_one_node);
5481 tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
5483 gfc_add_modify (&se->pre, size_words, tmp);
5484 gfc_add_modify (&se->pre, size_bytes,
5485 fold_build2_loc (input_location, MULT_EXPR,
5486 gfc_array_index_type,
5487 size_words, dest_word_len));
5488 upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5489 size_words, se->loop->from[n]);
5490 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5491 upper, gfc_index_one_node);
5495 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5496 size_words, gfc_index_one_node);
5497 se->loop->from[n] = gfc_index_zero_node;
5500 se->loop->to[n] = upper;
5502 /* Build a destination descriptor, using the pointer, source, as the
5504 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
5505 se->ss, mold_type, NULL_TREE, false, true, false,
5508 /* Cast the pointer to the result. */
5509 tmp = gfc_conv_descriptor_data_get (info->descriptor);
5510 tmp = fold_convert (pvoid_type_node, tmp);
5512 /* Use memcpy to do the transfer. */
5513 tmp = build_call_expr_loc (input_location,
5514 builtin_decl_explicit (BUILT_IN_MEMCPY),
5517 fold_convert (pvoid_type_node, source),
5518 fold_build2_loc (input_location, MIN_EXPR,
5519 gfc_array_index_type,
5520 size_bytes, source_bytes));
5521 gfc_add_expr_to_block (&se->pre, tmp);
5523 se->expr = info->descriptor;
5524 if (expr->ts.type == BT_CHARACTER)
5525 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
5529 /* Deal with scalar results. */
5531 extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
5532 dest_word_len, source_bytes);
5533 extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5534 extent, gfc_index_zero_node);
5536 if (expr->ts.type == BT_CHARACTER)
5541 ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
5542 tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
5545 /* If source is longer than the destination, use a pointer to
5546 the source directly. */
5547 gfc_init_block (&block);
5548 gfc_add_modify (&block, tmpdecl, ptr);
5549 direct = gfc_finish_block (&block);
5551 /* Otherwise, allocate a string with the length of the destination
5552 and copy the source into it. */
5553 gfc_init_block (&block);
5554 tmp = gfc_get_pchar_type (expr->ts.kind);
5555 tmp = gfc_call_malloc (&block, tmp, dest_word_len);
5556 gfc_add_modify (&block, tmpdecl,
5557 fold_convert (TREE_TYPE (ptr), tmp));
5558 tmp = build_call_expr_loc (input_location,
5559 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
5560 fold_convert (pvoid_type_node, tmpdecl),
5561 fold_convert (pvoid_type_node, ptr),
5563 gfc_add_expr_to_block (&block, tmp);
5564 indirect = gfc_finish_block (&block);
5566 /* Wrap it up with the condition. */
5567 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
5568 dest_word_len, source_bytes);
5569 tmp = build3_v (COND_EXPR, tmp, direct, indirect);
5570 gfc_add_expr_to_block (&se->pre, tmp);
5573 se->string_length = dest_word_len;
5577 tmpdecl = gfc_create_var (mold_type, "transfer");
5579 ptr = convert (build_pointer_type (mold_type), source);
5581 /* Use memcpy to do the transfer. */
5582 tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
5583 tmp = build_call_expr_loc (input_location,
5584 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
5585 fold_convert (pvoid_type_node, tmp),
5586 fold_convert (pvoid_type_node, ptr),
5588 gfc_add_expr_to_block (&se->pre, tmp);
5595 /* Generate code for the ALLOCATED intrinsic.
5596 Generate inline code that directly check the address of the argument. */
5599 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
5601 gfc_actual_arglist *arg1;
5606 gfc_init_se (&arg1se, NULL);
5607 arg1 = expr->value.function.actual;
5608 ss1 = gfc_walk_expr (arg1->expr);
5610 if (ss1 == gfc_ss_terminator)
5612 /* Allocatable scalar. */
5613 arg1se.want_pointer = 1;
5614 if (arg1->expr->ts.type == BT_CLASS)
5615 gfc_add_data_component (arg1->expr);
5616 gfc_conv_expr (&arg1se, arg1->expr);
5621 /* Allocatable array. */
5622 arg1se.descriptor_only = 1;
5623 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
5624 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
5627 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
5628 fold_convert (TREE_TYPE (tmp), null_pointer_node));
5629 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
5633 /* Generate code for the ASSOCIATED intrinsic.
5634 If both POINTER and TARGET are arrays, generate a call to library function
5635 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
5636 In other cases, generate inline code that directly compare the address of
5637 POINTER with the address of TARGET. */
5640 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
5642 gfc_actual_arglist *arg1;
5643 gfc_actual_arglist *arg2;
5648 tree nonzero_charlen;
5649 tree nonzero_arraylen;
5652 gfc_init_se (&arg1se, NULL);
5653 gfc_init_se (&arg2se, NULL);
5654 arg1 = expr->value.function.actual;
5655 if (arg1->expr->ts.type == BT_CLASS)
5656 gfc_add_data_component (arg1->expr);
5658 ss1 = gfc_walk_expr (arg1->expr);
5662 /* No optional target. */
5663 if (ss1 == gfc_ss_terminator)
5665 /* A pointer to a scalar. */
5666 arg1se.want_pointer = 1;
5667 gfc_conv_expr (&arg1se, arg1->expr);
5672 /* A pointer to an array. */
5673 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
5674 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
5676 gfc_add_block_to_block (&se->pre, &arg1se.pre);
5677 gfc_add_block_to_block (&se->post, &arg1se.post);
5678 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2,
5679 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
5684 /* An optional target. */
5685 if (arg2->expr->ts.type == BT_CLASS)
5686 gfc_add_data_component (arg2->expr);
5687 ss2 = gfc_walk_expr (arg2->expr);
5689 nonzero_charlen = NULL_TREE;
5690 if (arg1->expr->ts.type == BT_CHARACTER)
5691 nonzero_charlen = fold_build2_loc (input_location, NE_EXPR,
5693 arg1->expr->ts.u.cl->backend_decl,
5696 if (ss1 == gfc_ss_terminator)
5698 /* A pointer to a scalar. */
5699 gcc_assert (ss2 == gfc_ss_terminator);
5700 arg1se.want_pointer = 1;
5701 gfc_conv_expr (&arg1se, arg1->expr);
5702 arg2se.want_pointer = 1;
5703 gfc_conv_expr (&arg2se, arg2->expr);
5704 gfc_add_block_to_block (&se->pre, &arg1se.pre);
5705 gfc_add_block_to_block (&se->post, &arg1se.post);
5706 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5707 arg1se.expr, arg2se.expr);
5708 tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5709 arg1se.expr, null_pointer_node);
5710 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5711 boolean_type_node, tmp, tmp2);
5715 /* An array pointer of zero length is not associated if target is
5717 arg1se.descriptor_only = 1;
5718 gfc_conv_expr_lhs (&arg1se, arg1->expr);
5719 tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
5720 gfc_rank_cst[arg1->expr->rank - 1]);
5721 nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
5722 boolean_type_node, tmp,
5723 build_int_cst (TREE_TYPE (tmp), 0));
5725 /* A pointer to an array, call library function _gfor_associated. */
5726 gcc_assert (ss2 != gfc_ss_terminator);
5727 arg1se.want_pointer = 1;
5728 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
5730 arg2se.want_pointer = 1;
5731 gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
5732 gfc_add_block_to_block (&se->pre, &arg2se.pre);
5733 gfc_add_block_to_block (&se->post, &arg2se.post);
5734 se->expr = build_call_expr_loc (input_location,
5735 gfor_fndecl_associated, 2,
5736 arg1se.expr, arg2se.expr);
5737 se->expr = convert (boolean_type_node, se->expr);
5738 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5739 boolean_type_node, se->expr,
5743 /* If target is present zero character length pointers cannot
5745 if (nonzero_charlen != NULL_TREE)
5746 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5748 se->expr, nonzero_charlen);
5751 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
5755 /* Generate code for the SAME_TYPE_AS intrinsic.
5756 Generate inline code that directly checks the vindices. */
5759 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
5765 gfc_init_se (&se1, NULL);
5766 gfc_init_se (&se2, NULL);
5768 a = expr->value.function.actual->expr;
5769 b = expr->value.function.actual->next->expr;
5771 if (a->ts.type == BT_CLASS)
5773 gfc_add_vptr_component (a);
5774 gfc_add_hash_component (a);
5776 else if (a->ts.type == BT_DERIVED)
5777 a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5778 a->ts.u.derived->hash_value);
5780 if (b->ts.type == BT_CLASS)
5782 gfc_add_vptr_component (b);
5783 gfc_add_hash_component (b);
5785 else if (b->ts.type == BT_DERIVED)
5786 b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5787 b->ts.u.derived->hash_value);
5789 gfc_conv_expr (&se1, a);
5790 gfc_conv_expr (&se2, b);
5792 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5793 se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
5794 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
5798 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
5801 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
5805 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5806 se->expr = build_call_expr_loc (input_location,
5807 gfor_fndecl_sc_kind, 2, args[0], args[1]);
5808 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
5812 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
5815 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
5819 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5821 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
5822 type = gfc_get_int_type (4);
5823 arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
5825 /* Convert it to the required type. */
5826 type = gfc_typenode_for_spec (&expr->ts);
5827 se->expr = build_call_expr_loc (input_location,
5828 gfor_fndecl_si_kind, 1, arg);
5829 se->expr = fold_convert (type, se->expr);
5833 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
5836 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
5838 gfc_actual_arglist *actual;
5841 VEC(tree,gc) *args = NULL;
5843 for (actual = expr->value.function.actual; actual; actual = actual->next)
5845 gfc_init_se (&argse, se);
5847 /* Pass a NULL pointer for an absent arg. */
5848 if (actual->expr == NULL)
5849 argse.expr = null_pointer_node;
5855 if (actual->expr->ts.kind != gfc_c_int_kind)
5857 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
5858 ts.type = BT_INTEGER;
5859 ts.kind = gfc_c_int_kind;
5860 gfc_convert_type (actual->expr, &ts, 2);
5862 gfc_conv_expr_reference (&argse, actual->expr);
5865 gfc_add_block_to_block (&se->pre, &argse.pre);
5866 gfc_add_block_to_block (&se->post, &argse.post);
5867 VEC_safe_push (tree, gc, args, argse.expr);
5870 /* Convert it to the required type. */
5871 type = gfc_typenode_for_spec (&expr->ts);
5872 se->expr = build_call_expr_loc_vec (input_location,
5873 gfor_fndecl_sr_kind, args);
5874 se->expr = fold_convert (type, se->expr);
5878 /* Generate code for TRIM (A) intrinsic function. */
5881 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
5891 unsigned int num_args;
5893 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
5894 args = XALLOCAVEC (tree, num_args);
5896 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
5897 addr = gfc_build_addr_expr (ppvoid_type_node, var);
5898 len = gfc_create_var (gfc_charlen_type_node, "len");
5900 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
5901 args[0] = gfc_build_addr_expr (NULL_TREE, len);
5904 if (expr->ts.kind == 1)
5905 function = gfor_fndecl_string_trim;
5906 else if (expr->ts.kind == 4)
5907 function = gfor_fndecl_string_trim_char4;
5911 fndecl = build_addr (function, current_function_decl);
5912 tmp = build_call_array_loc (input_location,
5913 TREE_TYPE (TREE_TYPE (function)), fndecl,
5915 gfc_add_expr_to_block (&se->pre, tmp);
5917 /* Free the temporary afterwards, if necessary. */
5918 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
5919 len, build_int_cst (TREE_TYPE (len), 0));
5920 tmp = gfc_call_free (var);
5921 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
5922 gfc_add_expr_to_block (&se->post, tmp);
5925 se->string_length = len;
5929 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
5932 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
5934 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
5935 tree type, cond, tmp, count, exit_label, n, max, largest;
5937 stmtblock_t block, body;
5940 /* We store in charsize the size of a character. */
5941 i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
5942 size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
5944 /* Get the arguments. */
5945 gfc_conv_intrinsic_function_args (se, expr, args, 3);
5946 slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
5948 ncopies = gfc_evaluate_now (args[2], &se->pre);
5949 ncopies_type = TREE_TYPE (ncopies);
5951 /* Check that NCOPIES is not negative. */
5952 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, ncopies,
5953 build_int_cst (ncopies_type, 0));
5954 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
5955 "Argument NCOPIES of REPEAT intrinsic is negative "
5956 "(its value is %lld)",
5957 fold_convert (long_integer_type_node, ncopies));
5959 /* If the source length is zero, any non negative value of NCOPIES
5960 is valid, and nothing happens. */
5961 n = gfc_create_var (ncopies_type, "ncopies");
5962 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
5963 build_int_cst (size_type_node, 0));
5964 tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
5965 build_int_cst (ncopies_type, 0), ncopies);
5966 gfc_add_modify (&se->pre, n, tmp);
5969 /* Check that ncopies is not too large: ncopies should be less than
5970 (or equal to) MAX / slen, where MAX is the maximal integer of
5971 the gfc_charlen_type_node type. If slen == 0, we need a special
5972 case to avoid the division by zero. */
5973 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5974 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
5975 max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
5976 fold_convert (size_type_node, max), slen);
5977 largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
5978 ? size_type_node : ncopies_type;
5979 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
5980 fold_convert (largest, ncopies),
5981 fold_convert (largest, max));
5982 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
5983 build_int_cst (size_type_node, 0));
5984 cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp,
5985 boolean_false_node, cond);
5986 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
5987 "Argument NCOPIES of REPEAT intrinsic is too large");
5989 /* Compute the destination length. */
5990 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
5991 fold_convert (gfc_charlen_type_node, slen),
5992 fold_convert (gfc_charlen_type_node, ncopies));
5993 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
5994 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
5996 /* Generate the code to do the repeat operation:
5997 for (i = 0; i < ncopies; i++)
5998 memmove (dest + (i * slen * size), src, slen*size); */
5999 gfc_start_block (&block);
6000 count = gfc_create_var (ncopies_type, "count");
6001 gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
6002 exit_label = gfc_build_label_decl (NULL_TREE);
6004 /* Start the loop body. */
6005 gfc_start_block (&body);
6007 /* Exit the loop if count >= ncopies. */
6008 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, count,
6010 tmp = build1_v (GOTO_EXPR, exit_label);
6011 TREE_USED (exit_label) = 1;
6012 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6013 build_empty_stmt (input_location));
6014 gfc_add_expr_to_block (&body, tmp);
6016 /* Call memmove (dest + (i*slen*size), src, slen*size). */
6017 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
6018 fold_convert (gfc_charlen_type_node, slen),
6019 fold_convert (gfc_charlen_type_node, count));
6020 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
6021 tmp, fold_convert (gfc_charlen_type_node, size));
6022 tmp = fold_build_pointer_plus_loc (input_location,
6023 fold_convert (pvoid_type_node, dest), tmp);
6024 tmp = build_call_expr_loc (input_location,
6025 builtin_decl_explicit (BUILT_IN_MEMMOVE),
6027 fold_build2_loc (input_location, MULT_EXPR,
6028 size_type_node, slen,
6029 fold_convert (size_type_node,
6031 gfc_add_expr_to_block (&body, tmp);
6033 /* Increment count. */
6034 tmp = fold_build2_loc (input_location, PLUS_EXPR, ncopies_type,
6035 count, build_int_cst (TREE_TYPE (count), 1));
6036 gfc_add_modify (&body, count, tmp);
6038 /* Build the loop. */
6039 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
6040 gfc_add_expr_to_block (&block, tmp);
6042 /* Add the exit label. */
6043 tmp = build1_v (LABEL_EXPR, exit_label);
6044 gfc_add_expr_to_block (&block, tmp);
6046 /* Finish the block. */
6047 tmp = gfc_finish_block (&block);
6048 gfc_add_expr_to_block (&se->pre, tmp);
6050 /* Set the result value. */
6052 se->string_length = dlen;
6056 /* Generate code for the IARGC intrinsic. */
6059 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
6065 /* Call the library function. This always returns an INTEGER(4). */
6066 fndecl = gfor_fndecl_iargc;
6067 tmp = build_call_expr_loc (input_location,
6070 /* Convert it to the required type. */
6071 type = gfc_typenode_for_spec (&expr->ts);
6072 tmp = fold_convert (type, tmp);
6078 /* The loc intrinsic returns the address of its argument as
6079 gfc_index_integer_kind integer. */
6082 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
6088 gcc_assert (!se->ss);
6090 arg_expr = expr->value.function.actual->expr;
6091 ss = gfc_walk_expr (arg_expr);
6092 if (ss == gfc_ss_terminator)
6093 gfc_conv_expr_reference (se, arg_expr);
6095 gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL);
6096 se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
6098 /* Create a temporary variable for loc return value. Without this,
6099 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
6100 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
6101 gfc_add_modify (&se->pre, temp_var, se->expr);
6102 se->expr = temp_var;
6105 /* Generate code for an intrinsic function. Some map directly to library
6106 calls, others get special handling. In some cases the name of the function
6107 used depends on the type specifiers. */
6110 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
6116 name = &expr->value.function.name[2];
6120 lib = gfc_is_intrinsic_libcall (expr);
6124 se->ignore_optional = 1;
6126 switch (expr->value.function.isym->id)
6128 case GFC_ISYM_EOSHIFT:
6130 case GFC_ISYM_RESHAPE:
6131 /* For all of those the first argument specifies the type and the
6132 third is optional. */
6133 conv_generic_with_optional_char_arg (se, expr, 1, 3);
6137 gfc_conv_intrinsic_funcall (se, expr);
6145 switch (expr->value.function.isym->id)
6150 case GFC_ISYM_REPEAT:
6151 gfc_conv_intrinsic_repeat (se, expr);
6155 gfc_conv_intrinsic_trim (se, expr);
6158 case GFC_ISYM_SC_KIND:
6159 gfc_conv_intrinsic_sc_kind (se, expr);
6162 case GFC_ISYM_SI_KIND:
6163 gfc_conv_intrinsic_si_kind (se, expr);
6166 case GFC_ISYM_SR_KIND:
6167 gfc_conv_intrinsic_sr_kind (se, expr);
6170 case GFC_ISYM_EXPONENT:
6171 gfc_conv_intrinsic_exponent (se, expr);
6175 kind = expr->value.function.actual->expr->ts.kind;
6177 fndecl = gfor_fndecl_string_scan;
6179 fndecl = gfor_fndecl_string_scan_char4;
6183 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
6186 case GFC_ISYM_VERIFY:
6187 kind = expr->value.function.actual->expr->ts.kind;
6189 fndecl = gfor_fndecl_string_verify;
6191 fndecl = gfor_fndecl_string_verify_char4;
6195 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
6198 case GFC_ISYM_ALLOCATED:
6199 gfc_conv_allocated (se, expr);
6202 case GFC_ISYM_ASSOCIATED:
6203 gfc_conv_associated(se, expr);
6206 case GFC_ISYM_SAME_TYPE_AS:
6207 gfc_conv_same_type_as (se, expr);
6211 gfc_conv_intrinsic_abs (se, expr);
6214 case GFC_ISYM_ADJUSTL:
6215 if (expr->ts.kind == 1)
6216 fndecl = gfor_fndecl_adjustl;
6217 else if (expr->ts.kind == 4)
6218 fndecl = gfor_fndecl_adjustl_char4;
6222 gfc_conv_intrinsic_adjust (se, expr, fndecl);
6225 case GFC_ISYM_ADJUSTR:
6226 if (expr->ts.kind == 1)
6227 fndecl = gfor_fndecl_adjustr;
6228 else if (expr->ts.kind == 4)
6229 fndecl = gfor_fndecl_adjustr_char4;
6233 gfc_conv_intrinsic_adjust (se, expr, fndecl);
6236 case GFC_ISYM_AIMAG:
6237 gfc_conv_intrinsic_imagpart (se, expr);
6241 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
6245 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
6248 case GFC_ISYM_ANINT:
6249 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
6253 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
6257 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
6260 case GFC_ISYM_BTEST:
6261 gfc_conv_intrinsic_btest (se, expr);
6265 gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
6269 gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
6273 gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
6277 gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
6280 case GFC_ISYM_ACHAR:
6282 gfc_conv_intrinsic_char (se, expr);
6285 case GFC_ISYM_CONVERSION:
6287 case GFC_ISYM_LOGICAL:
6289 gfc_conv_intrinsic_conversion (se, expr);
6292 /* Integer conversions are handled separately to make sure we get the
6293 correct rounding mode. */
6298 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
6302 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
6305 case GFC_ISYM_CEILING:
6306 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
6309 case GFC_ISYM_FLOOR:
6310 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
6314 gfc_conv_intrinsic_mod (se, expr, 0);
6317 case GFC_ISYM_MODULO:
6318 gfc_conv_intrinsic_mod (se, expr, 1);
6321 case GFC_ISYM_CMPLX:
6322 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
6325 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
6326 gfc_conv_intrinsic_iargc (se, expr);
6329 case GFC_ISYM_COMPLEX:
6330 gfc_conv_intrinsic_cmplx (se, expr, 1);
6333 case GFC_ISYM_CONJG:
6334 gfc_conv_intrinsic_conjg (se, expr);
6337 case GFC_ISYM_COUNT:
6338 gfc_conv_intrinsic_count (se, expr);
6341 case GFC_ISYM_CTIME:
6342 gfc_conv_intrinsic_ctime (se, expr);
6346 gfc_conv_intrinsic_dim (se, expr);
6349 case GFC_ISYM_DOT_PRODUCT:
6350 gfc_conv_intrinsic_dot_product (se, expr);
6353 case GFC_ISYM_DPROD:
6354 gfc_conv_intrinsic_dprod (se, expr);
6357 case GFC_ISYM_DSHIFTL:
6358 gfc_conv_intrinsic_dshift (se, expr, true);
6361 case GFC_ISYM_DSHIFTR:
6362 gfc_conv_intrinsic_dshift (se, expr, false);
6365 case GFC_ISYM_FDATE:
6366 gfc_conv_intrinsic_fdate (se, expr);
6369 case GFC_ISYM_FRACTION:
6370 gfc_conv_intrinsic_fraction (se, expr);
6374 gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
6378 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
6382 gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
6385 case GFC_ISYM_IBCLR:
6386 gfc_conv_intrinsic_singlebitop (se, expr, 0);
6389 case GFC_ISYM_IBITS:
6390 gfc_conv_intrinsic_ibits (se, expr);
6393 case GFC_ISYM_IBSET:
6394 gfc_conv_intrinsic_singlebitop (se, expr, 1);
6397 case GFC_ISYM_IACHAR:
6398 case GFC_ISYM_ICHAR:
6399 /* We assume ASCII character sequence. */
6400 gfc_conv_intrinsic_ichar (se, expr);
6403 case GFC_ISYM_IARGC:
6404 gfc_conv_intrinsic_iargc (se, expr);
6408 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
6411 case GFC_ISYM_INDEX:
6412 kind = expr->value.function.actual->expr->ts.kind;
6414 fndecl = gfor_fndecl_string_index;
6416 fndecl = gfor_fndecl_string_index_char4;
6420 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
6424 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
6427 case GFC_ISYM_IPARITY:
6428 gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
6431 case GFC_ISYM_IS_IOSTAT_END:
6432 gfc_conv_has_intvalue (se, expr, LIBERROR_END);
6435 case GFC_ISYM_IS_IOSTAT_EOR:
6436 gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
6439 case GFC_ISYM_ISNAN:
6440 gfc_conv_intrinsic_isnan (se, expr);
6443 case GFC_ISYM_LSHIFT:
6444 gfc_conv_intrinsic_shift (se, expr, false, false);
6447 case GFC_ISYM_RSHIFT:
6448 gfc_conv_intrinsic_shift (se, expr, true, true);
6451 case GFC_ISYM_SHIFTA:
6452 gfc_conv_intrinsic_shift (se, expr, true, true);
6455 case GFC_ISYM_SHIFTL:
6456 gfc_conv_intrinsic_shift (se, expr, false, false);
6459 case GFC_ISYM_SHIFTR:
6460 gfc_conv_intrinsic_shift (se, expr, true, false);
6463 case GFC_ISYM_ISHFT:
6464 gfc_conv_intrinsic_ishft (se, expr);
6467 case GFC_ISYM_ISHFTC:
6468 gfc_conv_intrinsic_ishftc (se, expr);
6471 case GFC_ISYM_LEADZ:
6472 gfc_conv_intrinsic_leadz (se, expr);
6475 case GFC_ISYM_TRAILZ:
6476 gfc_conv_intrinsic_trailz (se, expr);
6479 case GFC_ISYM_POPCNT:
6480 gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
6483 case GFC_ISYM_POPPAR:
6484 gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
6487 case GFC_ISYM_LBOUND:
6488 gfc_conv_intrinsic_bound (se, expr, 0);
6491 case GFC_ISYM_LCOBOUND:
6492 conv_intrinsic_cobound (se, expr);
6495 case GFC_ISYM_TRANSPOSE:
6496 /* The scalarizer has already been set up for reversed dimension access
6497 order ; now we just get the argument value normally. */
6498 gfc_conv_expr (se, expr->value.function.actual->expr);
6502 gfc_conv_intrinsic_len (se, expr);
6505 case GFC_ISYM_LEN_TRIM:
6506 gfc_conv_intrinsic_len_trim (se, expr);
6510 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
6514 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
6518 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
6522 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
6525 case GFC_ISYM_MASKL:
6526 gfc_conv_intrinsic_mask (se, expr, 1);
6529 case GFC_ISYM_MASKR:
6530 gfc_conv_intrinsic_mask (se, expr, 0);
6534 if (expr->ts.type == BT_CHARACTER)
6535 gfc_conv_intrinsic_minmax_char (se, expr, 1);
6537 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
6540 case GFC_ISYM_MAXLOC:
6541 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
6544 case GFC_ISYM_MAXVAL:
6545 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
6548 case GFC_ISYM_MERGE:
6549 gfc_conv_intrinsic_merge (se, expr);
6552 case GFC_ISYM_MERGE_BITS:
6553 gfc_conv_intrinsic_merge_bits (se, expr);
6557 if (expr->ts.type == BT_CHARACTER)
6558 gfc_conv_intrinsic_minmax_char (se, expr, -1);
6560 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
6563 case GFC_ISYM_MINLOC:
6564 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
6567 case GFC_ISYM_MINVAL:
6568 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
6571 case GFC_ISYM_NEAREST:
6572 gfc_conv_intrinsic_nearest (se, expr);
6575 case GFC_ISYM_NORM2:
6576 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
6580 gfc_conv_intrinsic_not (se, expr);
6584 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
6587 case GFC_ISYM_PARITY:
6588 gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
6591 case GFC_ISYM_PRESENT:
6592 gfc_conv_intrinsic_present (se, expr);
6595 case GFC_ISYM_PRODUCT:
6596 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
6599 case GFC_ISYM_RRSPACING:
6600 gfc_conv_intrinsic_rrspacing (se, expr);
6603 case GFC_ISYM_SET_EXPONENT:
6604 gfc_conv_intrinsic_set_exponent (se, expr);
6607 case GFC_ISYM_SCALE:
6608 gfc_conv_intrinsic_scale (se, expr);
6612 gfc_conv_intrinsic_sign (se, expr);
6616 gfc_conv_intrinsic_size (se, expr);
6619 case GFC_ISYM_SIZEOF:
6620 case GFC_ISYM_C_SIZEOF:
6621 gfc_conv_intrinsic_sizeof (se, expr);
6624 case GFC_ISYM_STORAGE_SIZE:
6625 gfc_conv_intrinsic_storage_size (se, expr);
6628 case GFC_ISYM_SPACING:
6629 gfc_conv_intrinsic_spacing (se, expr);
6633 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
6636 case GFC_ISYM_TRANSFER:
6637 if (se->ss && se->ss->useflags)
6638 /* Access the previously obtained result. */
6639 gfc_conv_tmp_array_ref (se);
6641 gfc_conv_intrinsic_transfer (se, expr);
6644 case GFC_ISYM_TTYNAM:
6645 gfc_conv_intrinsic_ttynam (se, expr);
6648 case GFC_ISYM_UBOUND:
6649 gfc_conv_intrinsic_bound (se, expr, 1);
6652 case GFC_ISYM_UCOBOUND:
6653 conv_intrinsic_cobound (se, expr);
6657 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
6661 gfc_conv_intrinsic_loc (se, expr);
6664 case GFC_ISYM_THIS_IMAGE:
6665 /* For num_images() == 1, handle as LCOBOUND. */
6666 if (expr->value.function.actual->expr
6667 && gfc_option.coarray == GFC_FCOARRAY_SINGLE)
6668 conv_intrinsic_cobound (se, expr);
6670 trans_this_image (se, expr);
6673 case GFC_ISYM_IMAGE_INDEX:
6674 trans_image_index (se, expr);
6677 case GFC_ISYM_NUM_IMAGES:
6678 trans_num_images (se);
6681 case GFC_ISYM_ACCESS:
6682 case GFC_ISYM_CHDIR:
6683 case GFC_ISYM_CHMOD:
6684 case GFC_ISYM_DTIME:
6685 case GFC_ISYM_ETIME:
6686 case GFC_ISYM_EXTENDS_TYPE_OF:
6688 case GFC_ISYM_FGETC:
6691 case GFC_ISYM_FPUTC:
6692 case GFC_ISYM_FSTAT:
6693 case GFC_ISYM_FTELL:
6694 case GFC_ISYM_GETCWD:
6695 case GFC_ISYM_GETGID:
6696 case GFC_ISYM_GETPID:
6697 case GFC_ISYM_GETUID:
6698 case GFC_ISYM_HOSTNM:
6700 case GFC_ISYM_IERRNO:
6701 case GFC_ISYM_IRAND:
6702 case GFC_ISYM_ISATTY:
6705 case GFC_ISYM_LSTAT:
6706 case GFC_ISYM_MALLOC:
6707 case GFC_ISYM_MATMUL:
6708 case GFC_ISYM_MCLOCK:
6709 case GFC_ISYM_MCLOCK8:
6711 case GFC_ISYM_RENAME:
6712 case GFC_ISYM_SECOND:
6713 case GFC_ISYM_SECNDS:
6714 case GFC_ISYM_SIGNAL:
6716 case GFC_ISYM_SYMLNK:
6717 case GFC_ISYM_SYSTEM:
6719 case GFC_ISYM_TIME8:
6720 case GFC_ISYM_UMASK:
6721 case GFC_ISYM_UNLINK:
6723 gfc_conv_intrinsic_funcall (se, expr);
6726 case GFC_ISYM_EOSHIFT:
6728 case GFC_ISYM_RESHAPE:
6729 /* For those, expr->rank should always be >0 and thus the if above the
6730 switch should have matched. */
6735 gfc_conv_intrinsic_lib_function (se, expr);
6742 walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
6744 gfc_ss *arg_ss, *tmp_ss;
6745 gfc_actual_arglist *arg;
6747 arg = expr->value.function.actual;
6749 gcc_assert (arg->expr);
6751 arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
6752 gcc_assert (arg_ss != gfc_ss_terminator);
6754 for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
6756 if (tmp_ss->type != GFC_SS_SCALAR
6757 && tmp_ss->type != GFC_SS_REFERENCE)
6761 gcc_assert (tmp_ss->dimen == 2);
6763 /* We just invert dimensions. */
6764 tmp_dim = tmp_ss->dim[0];
6765 tmp_ss->dim[0] = tmp_ss->dim[1];
6766 tmp_ss->dim[1] = tmp_dim;
6769 /* Stop when tmp_ss points to the last valid element of the chain... */
6770 if (tmp_ss->next == gfc_ss_terminator)
6774 /* ... so that we can attach the rest of the chain to it. */
6782 walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
6785 switch (expr->value.function.isym->id)
6787 case GFC_ISYM_TRANSPOSE:
6788 return walk_inline_intrinsic_transpose (ss, expr);
6797 /* This generates code to execute before entering the scalarization loop.
6798 Currently does nothing. */
6801 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
6803 switch (ss->expr->value.function.isym->id)
6805 case GFC_ISYM_UBOUND:
6806 case GFC_ISYM_LBOUND:
6807 case GFC_ISYM_UCOBOUND:
6808 case GFC_ISYM_LCOBOUND:
6809 case GFC_ISYM_THIS_IMAGE:
6818 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
6819 are expanded into code inside the scalarization loop. */
6822 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
6824 /* The two argument version returns a scalar. */
6825 if (expr->value.function.actual->next->expr)
6828 return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
6832 /* Walk an intrinsic array libcall. */
6835 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
6837 gcc_assert (expr->rank > 0);
6838 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
6842 /* Return whether the function call expression EXPR will be expanded
6843 inline by gfc_conv_intrinsic_function. */
6846 gfc_inline_intrinsic_function_p (gfc_expr *expr)
6848 if (!expr->value.function.isym)
6851 switch (expr->value.function.isym->id)
6853 case GFC_ISYM_TRANSPOSE:
6862 /* Returns nonzero if the specified intrinsic function call maps directly to
6863 an external library call. Should only be used for functions that return
6867 gfc_is_intrinsic_libcall (gfc_expr * expr)
6869 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
6870 gcc_assert (expr->rank > 0);
6872 if (gfc_inline_intrinsic_function_p (expr))
6875 switch (expr->value.function.isym->id)
6879 case GFC_ISYM_COUNT:
6883 case GFC_ISYM_IPARITY:
6884 case GFC_ISYM_MATMUL:
6885 case GFC_ISYM_MAXLOC:
6886 case GFC_ISYM_MAXVAL:
6887 case GFC_ISYM_MINLOC:
6888 case GFC_ISYM_MINVAL:
6889 case GFC_ISYM_NORM2:
6890 case GFC_ISYM_PARITY:
6891 case GFC_ISYM_PRODUCT:
6893 case GFC_ISYM_SHAPE:
6894 case GFC_ISYM_SPREAD:
6896 /* Ignore absent optional parameters. */
6899 case GFC_ISYM_RESHAPE:
6900 case GFC_ISYM_CSHIFT:
6901 case GFC_ISYM_EOSHIFT:
6903 case GFC_ISYM_UNPACK:
6904 /* Pass absent optional parameters. */
6912 /* Walk an intrinsic function. */
6914 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
6915 gfc_intrinsic_sym * isym)
6919 if (isym->elemental)
6920 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6923 if (expr->rank == 0)
6926 if (gfc_inline_intrinsic_function_p (expr))
6927 return walk_inline_intrinsic_function (ss, expr);
6929 if (gfc_is_intrinsic_libcall (expr))
6930 return gfc_walk_intrinsic_libfunc (ss, expr);
6932 /* Special cases. */
6935 case GFC_ISYM_LBOUND:
6936 case GFC_ISYM_LCOBOUND:
6937 case GFC_ISYM_UBOUND:
6938 case GFC_ISYM_UCOBOUND:
6939 case GFC_ISYM_THIS_IMAGE:
6940 return gfc_walk_intrinsic_bound (ss, expr);
6942 case GFC_ISYM_TRANSFER:
6943 return gfc_walk_intrinsic_libfunc (ss, expr);
6946 /* This probably meant someone forgot to add an intrinsic to the above
6947 list(s) when they implemented it, or something's gone horribly
6955 conv_intrinsic_atomic_def (gfc_code *code)
6960 gfc_init_se (&atom, NULL);
6961 gfc_init_se (&value, NULL);
6962 gfc_conv_expr (&atom, code->ext.actual->expr);
6963 gfc_conv_expr (&value, code->ext.actual->next->expr);
6965 gfc_init_block (&block);
6966 gfc_add_modify (&block, atom.expr,
6967 fold_convert (TREE_TYPE (atom.expr), value.expr));
6968 return gfc_finish_block (&block);
6973 conv_intrinsic_atomic_ref (gfc_code *code)
6978 gfc_init_se (&atom, NULL);
6979 gfc_init_se (&value, NULL);
6980 gfc_conv_expr (&value, code->ext.actual->expr);
6981 gfc_conv_expr (&atom, code->ext.actual->next->expr);
6983 gfc_init_block (&block);
6984 gfc_add_modify (&block, value.expr,
6985 fold_convert (TREE_TYPE (value.expr), atom.expr));
6986 return gfc_finish_block (&block);
6991 conv_intrinsic_move_alloc (gfc_code *code)
6993 if (code->ext.actual->expr->rank == 0)
6995 /* Scalar arguments: Generate pointer assignments. */
6996 gfc_expr *from, *to, *deal;
7001 from = code->ext.actual->expr;
7002 to = code->ext.actual->next->expr;
7004 gfc_start_block (&block);
7006 /* Deallocate 'TO' argument. */
7007 gfc_init_se (&se, NULL);
7008 se.want_pointer = 1;
7009 deal = gfc_copy_expr (to);
7010 if (deal->ts.type == BT_CLASS)
7011 gfc_add_data_component (deal);
7012 gfc_conv_expr (&se, deal);
7013 tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
7015 gfc_add_expr_to_block (&block, tmp);
7016 gfc_free_expr (deal);
7018 if (to->ts.type == BT_CLASS)
7019 tmp = gfc_trans_class_assign (to, from, EXEC_POINTER_ASSIGN);
7021 tmp = gfc_trans_pointer_assignment (to, from);
7022 gfc_add_expr_to_block (&block, tmp);
7024 if (from->ts.type == BT_CLASS)
7025 tmp = gfc_trans_class_assign (from, gfc_get_null_expr (NULL),
7026 EXEC_POINTER_ASSIGN);
7028 tmp = gfc_trans_pointer_assignment (from,
7029 gfc_get_null_expr (NULL));
7030 gfc_add_expr_to_block (&block, tmp);
7032 return gfc_finish_block (&block);
7035 /* Array arguments: Generate library code. */
7036 return gfc_trans_call (code, false, NULL_TREE, NULL_TREE, false);
7041 gfc_conv_intrinsic_subroutine (gfc_code *code)
7045 gcc_assert (code->resolved_isym);
7047 switch (code->resolved_isym->id)
7049 case GFC_ISYM_MOVE_ALLOC:
7050 res = conv_intrinsic_move_alloc (code);
7053 case GFC_ISYM_ATOMIC_DEF:
7054 res = conv_intrinsic_atomic_def (code);
7057 case GFC_ISYM_ATOMIC_REF:
7058 res = conv_intrinsic_atomic_ref (code);
7069 #include "gt-fortran-trans-intrinsic.h"