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 int i = END_BUILTINS;
144 gfc_intrinsic_map_t *m;
145 for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
148 if (precision == TYPE_PRECISION (float_type_node))
149 i = m->float_built_in;
150 else if (precision == TYPE_PRECISION (double_type_node))
151 i = m->double_built_in;
152 else if (precision == TYPE_PRECISION (long_double_type_node))
153 i = m->long_double_built_in;
154 else if (precision == TYPE_PRECISION (float128_type_node))
156 /* Special treatment, because it is not exactly a built-in, but
157 a library function. */
158 return m->real16_decl;
161 return (i == END_BUILTINS ? NULL_TREE : built_in_decls[i]);
166 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
169 int i = gfc_validate_kind (BT_REAL, kind, false);
171 if (gfc_real_kinds[i].c_float128)
173 /* For __float128, the story is a bit different, because we return
174 a decl to a library function rather than a built-in. */
175 gfc_intrinsic_map_t *m;
176 for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
179 return m->real16_decl;
182 return builtin_decl_for_precision (double_built_in,
183 gfc_real_kinds[i].mode_precision);
187 /* Evaluate the arguments to an intrinsic function. The value
188 of NARGS may be less than the actual number of arguments in EXPR
189 to allow optional "KIND" arguments that are not included in the
190 generated code to be ignored. */
193 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
194 tree *argarray, int nargs)
196 gfc_actual_arglist *actual;
198 gfc_intrinsic_arg *formal;
202 formal = expr->value.function.isym->formal;
203 actual = expr->value.function.actual;
205 for (curr_arg = 0; curr_arg < nargs; curr_arg++,
206 actual = actual->next,
207 formal = formal ? formal->next : NULL)
211 /* Skip omitted optional arguments. */
218 /* Evaluate the parameter. This will substitute scalarized
219 references automatically. */
220 gfc_init_se (&argse, se);
222 if (e->ts.type == BT_CHARACTER)
224 gfc_conv_expr (&argse, e);
225 gfc_conv_string_parameter (&argse);
226 argarray[curr_arg++] = argse.string_length;
227 gcc_assert (curr_arg < nargs);
230 gfc_conv_expr_val (&argse, e);
232 /* If an optional argument is itself an optional dummy argument,
233 check its presence and substitute a null if absent. */
234 if (e->expr_type == EXPR_VARIABLE
235 && e->symtree->n.sym->attr.optional
238 gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
240 gfc_add_block_to_block (&se->pre, &argse.pre);
241 gfc_add_block_to_block (&se->post, &argse.post);
242 argarray[curr_arg] = argse.expr;
246 /* Count the number of actual arguments to the intrinsic function EXPR
247 including any "hidden" string length arguments. */
250 gfc_intrinsic_argument_list_length (gfc_expr *expr)
253 gfc_actual_arglist *actual;
255 for (actual = expr->value.function.actual; actual; actual = actual->next)
260 if (actual->expr->ts.type == BT_CHARACTER)
270 /* Conversions between different types are output by the frontend as
271 intrinsic functions. We implement these directly with inline code. */
274 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
280 nargs = gfc_intrinsic_argument_list_length (expr);
281 args = XALLOCAVEC (tree, nargs);
283 /* Evaluate all the arguments passed. Whilst we're only interested in the
284 first one here, there are other parts of the front-end that assume this
285 and will trigger an ICE if it's not the case. */
286 type = gfc_typenode_for_spec (&expr->ts);
287 gcc_assert (expr->value.function.actual->expr);
288 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
290 /* Conversion between character kinds involves a call to a library
292 if (expr->ts.type == BT_CHARACTER)
294 tree fndecl, var, addr, tmp;
296 if (expr->ts.kind == 1
297 && expr->value.function.actual->expr->ts.kind == 4)
298 fndecl = gfor_fndecl_convert_char4_to_char1;
299 else if (expr->ts.kind == 4
300 && expr->value.function.actual->expr->ts.kind == 1)
301 fndecl = gfor_fndecl_convert_char1_to_char4;
305 /* Create the variable storing the converted value. */
306 type = gfc_get_pchar_type (expr->ts.kind);
307 var = gfc_create_var (type, "str");
308 addr = gfc_build_addr_expr (build_pointer_type (type), var);
310 /* Call the library function that will perform the conversion. */
311 gcc_assert (nargs >= 2);
312 tmp = build_call_expr_loc (input_location,
313 fndecl, 3, addr, args[0], args[1]);
314 gfc_add_expr_to_block (&se->pre, tmp);
316 /* Free the temporary afterwards. */
317 tmp = gfc_call_free (var);
318 gfc_add_expr_to_block (&se->post, tmp);
321 se->string_length = args[0];
326 /* Conversion from complex to non-complex involves taking the real
327 component of the value. */
328 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
329 && expr->ts.type != BT_COMPLEX)
333 artype = TREE_TYPE (TREE_TYPE (args[0]));
334 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
338 se->expr = convert (type, args[0]);
341 /* This is needed because the gcc backend only implements
342 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
343 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
344 Similarly for CEILING. */
347 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
354 argtype = TREE_TYPE (arg);
355 arg = gfc_evaluate_now (arg, pblock);
357 intval = convert (type, arg);
358 intval = gfc_evaluate_now (intval, pblock);
360 tmp = convert (argtype, intval);
361 cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
362 boolean_type_node, tmp, arg);
364 tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
365 intval, build_int_cst (type, 1));
366 tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
371 /* Round to nearest integer, away from zero. */
374 build_round_expr (tree arg, tree restype)
379 int argprec, resprec;
381 argtype = TREE_TYPE (arg);
382 argprec = TYPE_PRECISION (argtype);
383 resprec = TYPE_PRECISION (restype);
385 /* Depending on the type of the result, choose the long int intrinsic
386 (lround family) or long long intrinsic (llround). We might also
387 need to convert the result afterwards. */
388 if (resprec <= LONG_TYPE_SIZE)
390 else if (resprec <= LONG_LONG_TYPE_SIZE)
395 /* Now, depending on the argument type, we choose between intrinsics. */
397 fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
399 fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
401 return fold_convert (restype, build_call_expr_loc (input_location,
406 /* Convert a real to an integer using a specific rounding mode.
407 Ideally we would just build the corresponding GENERIC node,
408 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
411 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
412 enum rounding_mode op)
417 return build_fixbound_expr (pblock, arg, type, 0);
421 return build_fixbound_expr (pblock, arg, type, 1);
425 return build_round_expr (arg, type);
429 return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
438 /* Round a real value using the specified rounding mode.
439 We use a temporary integer of that same kind size as the result.
440 Values larger than those that can be represented by this kind are
441 unchanged, as they will not be accurate enough to represent the
443 huge = HUGE (KIND (a))
444 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
448 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
460 kind = expr->ts.kind;
461 nargs = gfc_intrinsic_argument_list_length (expr);
464 /* We have builtin functions for some cases. */
468 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
472 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
479 /* Evaluate the argument. */
480 gcc_assert (expr->value.function.actual->expr);
481 gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
483 /* Use a builtin function if one exists. */
484 if (decl != NULL_TREE)
486 se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
490 /* This code is probably redundant, but we'll keep it lying around just
492 type = gfc_typenode_for_spec (&expr->ts);
493 arg[0] = gfc_evaluate_now (arg[0], &se->pre);
495 /* Test if the value is too large to handle sensibly. */
496 gfc_set_model_kind (kind);
498 n = gfc_validate_kind (BT_INTEGER, kind, false);
499 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
500 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
501 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, arg[0],
504 mpfr_neg (huge, huge, GFC_RND_MODE);
505 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
506 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, arg[0],
508 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
510 itype = gfc_get_int_type (kind);
512 tmp = build_fix_expr (&se->pre, arg[0], itype, op);
513 tmp = convert (type, tmp);
514 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
520 /* Convert to an integer using the specified rounding mode. */
523 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
529 nargs = gfc_intrinsic_argument_list_length (expr);
530 args = XALLOCAVEC (tree, nargs);
532 /* Evaluate the argument, we process all arguments even though we only
533 use the first one for code generation purposes. */
534 type = gfc_typenode_for_spec (&expr->ts);
535 gcc_assert (expr->value.function.actual->expr);
536 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
538 if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
540 /* Conversion to a different integer kind. */
541 se->expr = convert (type, args[0]);
545 /* Conversion from complex to non-complex involves taking the real
546 component of the value. */
547 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
548 && expr->ts.type != BT_COMPLEX)
552 artype = TREE_TYPE (TREE_TYPE (args[0]));
553 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
557 se->expr = build_fix_expr (&se->pre, args[0], type, op);
562 /* Get the imaginary component of a value. */
565 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
569 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
570 se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
571 TREE_TYPE (TREE_TYPE (arg)), arg);
575 /* Get the complex conjugate of a value. */
578 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
582 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
583 se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
589 define_quad_builtin (const char *name, tree type, bool is_const)
592 fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
595 /* Mark the decl as external. */
596 DECL_EXTERNAL (fndecl) = 1;
597 TREE_PUBLIC (fndecl) = 1;
599 /* Mark it __attribute__((const)). */
600 TREE_READONLY (fndecl) = is_const;
602 rest_of_decl_compilation (fndecl, 1, 0);
609 /* Initialize function decls for library functions. The external functions
610 are created as required. Builtin functions are added here. */
613 gfc_build_intrinsic_lib_fndecls (void)
615 gfc_intrinsic_map_t *m;
616 tree quad_decls[END_BUILTINS + 1];
618 if (gfc_real16_is_float128)
620 /* If we have soft-float types, we create the decls for their
621 C99-like library functions. For now, we only handle __float128
622 q-suffixed functions. */
624 tree 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 = built_in_decls[m->float_built_in];
683 if (m->complex_float_built_in != END_BUILTINS)
684 m->complex4_decl = built_in_decls[m->complex_float_built_in];
685 if (m->double_built_in != END_BUILTINS)
686 m->real8_decl = built_in_decls[m->double_built_in];
687 if (m->complex_double_built_in != END_BUILTINS)
688 m->complex8_decl = built_in_decls[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 = built_in_decls[m->long_double_built_in];
693 if (m->complex_long_double_built_in != END_BUILTINS)
694 m->complex10_decl = built_in_decls[m->complex_long_double_built_in];
696 if (!gfc_real16_is_float128)
698 if (m->long_double_built_in != END_BUILTINS)
699 m->real16_decl = built_in_decls[m->long_double_built_in];
700 if (m->complex_long_double_built_in != END_BUILTINS)
701 m->complex16_decl = built_in_decls[m->complex_long_double_built_in];
703 else if (quad_decls[m->double_built_in] != NULL_TREE)
705 /* Quad-precision function calls are constructed when first
706 needed by builtin_decl_for_precision(), except for those
707 that will be used directly (define by OTHER_BUILTIN). */
708 m->real16_decl = quad_decls[m->double_built_in];
710 else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
712 /* Same thing for the complex ones. */
713 m->complex16_decl = quad_decls[m->double_built_in];
719 /* Create a fndecl for a simple intrinsic library function. */
722 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
725 VEC(tree,gc) *argtypes;
727 gfc_actual_arglist *actual;
730 char name[GFC_MAX_SYMBOL_LEN + 3];
733 if (ts->type == BT_REAL)
738 pdecl = &m->real4_decl;
741 pdecl = &m->real8_decl;
744 pdecl = &m->real10_decl;
747 pdecl = &m->real16_decl;
753 else if (ts->type == BT_COMPLEX)
755 gcc_assert (m->complex_available);
760 pdecl = &m->complex4_decl;
763 pdecl = &m->complex8_decl;
766 pdecl = &m->complex10_decl;
769 pdecl = &m->complex16_decl;
783 int n = gfc_validate_kind (BT_REAL, ts->kind, false);
784 if (gfc_real_kinds[n].c_float)
785 snprintf (name, sizeof (name), "%s%s%s",
786 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
787 else if (gfc_real_kinds[n].c_double)
788 snprintf (name, sizeof (name), "%s%s",
789 ts->type == BT_COMPLEX ? "c" : "", m->name);
790 else if (gfc_real_kinds[n].c_long_double)
791 snprintf (name, sizeof (name), "%s%s%s",
792 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
793 else if (gfc_real_kinds[n].c_float128)
794 snprintf (name, sizeof (name), "%s%s%s",
795 ts->type == BT_COMPLEX ? "c" : "", m->name, "q");
801 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
802 ts->type == BT_COMPLEX ? 'c' : 'r',
807 for (actual = expr->value.function.actual; actual; actual = actual->next)
809 type = gfc_typenode_for_spec (&actual->expr->ts);
810 VEC_safe_push (tree, gc, argtypes, type);
812 type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
813 fndecl = build_decl (input_location,
814 FUNCTION_DECL, get_identifier (name), type);
816 /* Mark the decl as external. */
817 DECL_EXTERNAL (fndecl) = 1;
818 TREE_PUBLIC (fndecl) = 1;
820 /* Mark it __attribute__((const)), if possible. */
821 TREE_READONLY (fndecl) = m->is_constant;
823 rest_of_decl_compilation (fndecl, 1, 0);
830 /* Convert an intrinsic function into an external or builtin call. */
833 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
835 gfc_intrinsic_map_t *m;
839 unsigned int num_args;
842 id = expr->value.function.isym->id;
843 /* Find the entry for this function. */
844 for (m = gfc_intrinsic_map;
845 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
851 if (m->id == GFC_ISYM_NONE)
853 internal_error ("Intrinsic function %s(%d) not recognized",
854 expr->value.function.name, id);
857 /* Get the decl and generate the call. */
858 num_args = gfc_intrinsic_argument_list_length (expr);
859 args = XALLOCAVEC (tree, num_args);
861 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
862 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
863 rettype = TREE_TYPE (TREE_TYPE (fndecl));
865 fndecl = build_addr (fndecl, current_function_decl);
866 se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
870 /* If bounds-checking is enabled, create code to verify at runtime that the
871 string lengths for both expressions are the same (needed for e.g. MERGE).
872 If bounds-checking is not enabled, does nothing. */
875 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
876 tree a, tree b, stmtblock_t* target)
881 /* If bounds-checking is disabled, do nothing. */
882 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
885 /* Compare the two string lengths. */
886 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, a, b);
888 /* Output the runtime-check. */
889 name = gfc_build_cstring_const (intr_name);
890 name = gfc_build_addr_expr (pchar_type_node, name);
891 gfc_trans_runtime_check (true, false, cond, target, where,
892 "Unequal character lengths (%ld/%ld) in %s",
893 fold_convert (long_integer_type_node, a),
894 fold_convert (long_integer_type_node, b), name);
898 /* The EXPONENT(s) intrinsic function is translated into
905 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
907 tree arg, type, res, tmp, frexp;
909 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
910 expr->value.function.actual->expr->ts.kind);
912 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
914 res = gfc_create_var (integer_type_node, NULL);
915 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
916 gfc_build_addr_expr (NULL_TREE, res));
917 gfc_add_expr_to_block (&se->pre, tmp);
919 type = gfc_typenode_for_spec (&expr->ts);
920 se->expr = fold_convert (type, res);
924 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
925 AR_FULL, suitable for the scalarizer. */
928 convert_element_to_coarray_ref (gfc_expr *expr)
932 for (ref = expr->ref; ref; ref = ref->next)
933 if (ref->type == REF_ARRAY && ref->next == NULL
934 && ref->u.ar.codimen)
936 ref->u.ar.type = AR_FULL;
943 trans_this_image (gfc_se * se, gfc_expr *expr)
946 tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
947 lbound, ubound, extent, ml;
952 /* The case -fcoarray=single is handled elsewhere. */
953 gcc_assert (gfc_option.coarray != GFC_FCOARRAY_SINGLE);
955 gfc_init_coarray_decl (false);
957 /* Argument-free version: THIS_IMAGE(). */
958 if (expr->value.function.actual->expr == NULL)
960 se->expr = gfort_gvar_caf_this_image;
964 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
966 type = gfc_get_int_type (gfc_default_integer_kind);
967 corank = gfc_get_corank (expr->value.function.actual->expr);
968 rank = expr->value.function.actual->expr->rank;
970 /* Obtain the descriptor of the COARRAY. */
971 gfc_init_se (&argse, NULL);
972 if (expr->value.function.actual->expr->rank == 0)
973 convert_element_to_coarray_ref (expr->value.function.actual->expr);
974 ss = gfc_walk_expr (expr->value.function.actual->expr);
975 gcc_assert (ss != gfc_ss_terminator);
976 ss->data.info.codimen = corank;
977 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
978 gfc_add_block_to_block (&se->pre, &argse.pre);
979 gfc_add_block_to_block (&se->post, &argse.post);
984 /* Create an implicit second parameter from the loop variable. */
985 gcc_assert (!expr->value.function.actual->next->expr);
986 gcc_assert (corank > 0);
987 gcc_assert (se->loop->dimen == 1);
988 gcc_assert (se->ss->expr == expr);
990 dim_arg = se->loop->loopvar[0];
991 dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
992 gfc_array_index_type, dim_arg,
993 build_int_cst (TREE_TYPE (dim_arg), 1));
994 gfc_advance_se_ss_chain (se);
998 /* Use the passed DIM= argument. */
999 gcc_assert (expr->value.function.actual->next->expr);
1000 gfc_init_se (&argse, NULL);
1001 gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
1002 gfc_array_index_type);
1003 gfc_add_block_to_block (&se->pre, &argse.pre);
1004 dim_arg = argse.expr;
1006 if (INTEGER_CST_P (dim_arg))
1010 hi = TREE_INT_CST_HIGH (dim_arg);
1011 co_dim = TREE_INT_CST_LOW (dim_arg);
1012 if (hi || co_dim < 1
1013 || co_dim > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
1014 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1015 "dimension index", expr->value.function.isym->name,
1018 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1020 dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
1021 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1023 build_int_cst (TREE_TYPE (dim_arg), 1));
1024 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
1025 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1027 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1028 boolean_type_node, cond, tmp);
1029 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1034 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1035 one always has a dim_arg argument.
1037 m = this_images() - 1
1039 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1042 extent = gfc_extent(i)
1050 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1051 : m + lcobound(corank)
1054 m = gfc_create_var (type, NULL);
1055 ml = gfc_create_var (type, NULL);
1056 loop_var = gfc_create_var (integer_type_node, NULL);
1057 min_var = gfc_create_var (integer_type_node, NULL);
1059 /* m = this_image () - 1. */
1060 tmp = fold_convert (type, gfort_gvar_caf_this_image);
1061 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, tmp,
1062 build_int_cst (type, 1));
1063 gfc_add_modify (&se->pre, m, tmp);
1065 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1066 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
1067 fold_convert (integer_type_node, dim_arg),
1068 build_int_cst (integer_type_node, rank - 1));
1069 tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
1070 build_int_cst (integer_type_node, rank + corank - 2),
1072 gfc_add_modify (&se->pre, min_var, tmp);
1075 tmp = build_int_cst (integer_type_node, rank);
1076 gfc_add_modify (&se->pre, loop_var, tmp);
1078 exit_label = gfc_build_label_decl (NULL_TREE);
1079 TREE_USED (exit_label) = 1;
1082 gfc_init_block (&loop);
1085 gfc_add_modify (&loop, ml, m);
1088 lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
1089 ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
1090 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1091 extent = fold_convert (type, extent);
1094 gfc_add_modify (&loop, m,
1095 fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
1098 /* Exit condition: if (i >= min_var) goto exit_label. */
1099 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, loop_var,
1101 tmp = build1_v (GOTO_EXPR, exit_label);
1102 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
1103 build_empty_stmt (input_location));
1104 gfc_add_expr_to_block (&loop, tmp);
1106 /* Increment loop variable: i++. */
1107 gfc_add_modify (&loop, loop_var,
1108 fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
1110 build_int_cst (integer_type_node, 1)));
1112 /* Making the loop... actually loop! */
1113 tmp = gfc_finish_block (&loop);
1114 tmp = build1_v (LOOP_EXPR, tmp);
1115 gfc_add_expr_to_block (&se->pre, tmp);
1117 /* The exit label. */
1118 tmp = build1_v (LABEL_EXPR, exit_label);
1119 gfc_add_expr_to_block (&se->pre, tmp);
1121 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1122 : m + lcobound(corank) */
1124 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, dim_arg,
1125 build_int_cst (TREE_TYPE (dim_arg), corank));
1127 lbound = gfc_conv_descriptor_lbound_get (desc,
1128 fold_build2_loc (input_location, PLUS_EXPR,
1129 gfc_array_index_type, dim_arg,
1130 build_int_cst (TREE_TYPE (dim_arg), rank-1)));
1131 lbound = fold_convert (type, lbound);
1133 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
1134 fold_build2_loc (input_location, MULT_EXPR, type,
1136 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
1138 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
1139 fold_build2_loc (input_location, PLUS_EXPR, type,
1145 trans_image_index (gfc_se * se, gfc_expr *expr)
1147 tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
1149 gfc_se argse, subse;
1151 int rank, corank, codim;
1153 type = gfc_get_int_type (gfc_default_integer_kind);
1154 corank = gfc_get_corank (expr->value.function.actual->expr);
1155 rank = expr->value.function.actual->expr->rank;
1157 /* Obtain the descriptor of the COARRAY. */
1158 gfc_init_se (&argse, NULL);
1159 if (expr->value.function.actual->expr->rank == 0)
1160 convert_element_to_coarray_ref (expr->value.function.actual->expr);
1161 ss = gfc_walk_expr (expr->value.function.actual->expr);
1162 gcc_assert (ss != gfc_ss_terminator);
1163 ss->data.info.codimen = corank;
1164 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
1165 gfc_add_block_to_block (&se->pre, &argse.pre);
1166 gfc_add_block_to_block (&se->post, &argse.post);
1169 /* Obtain a handle to the SUB argument. */
1170 gfc_init_se (&subse, NULL);
1171 subss = gfc_walk_expr (expr->value.function.actual->next->expr);
1172 gcc_assert (subss != gfc_ss_terminator);
1173 gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr,
1175 gfc_add_block_to_block (&se->pre, &subse.pre);
1176 gfc_add_block_to_block (&se->post, &subse.post);
1177 subdesc = build_fold_indirect_ref_loc (input_location,
1178 gfc_conv_descriptor_data_get (subse.expr));
1180 /* Fortran 2008 does not require that the values remain in the cobounds,
1181 thus we need explicitly check this - and return 0 if they are exceeded. */
1183 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
1184 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
1185 invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1186 fold_convert (gfc_array_index_type, tmp),
1189 for (codim = corank + rank - 2; codim >= rank; codim--)
1191 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1192 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
1193 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
1194 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1195 fold_convert (gfc_array_index_type, tmp),
1197 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1198 boolean_type_node, invalid_bound, cond);
1199 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1200 fold_convert (gfc_array_index_type, tmp),
1202 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1203 boolean_type_node, invalid_bound, cond);
1206 invalid_bound = gfc_unlikely (invalid_bound);
1209 /* See Fortran 2008, C.10 for the following algorithm. */
1211 /* coindex = sub(corank) - lcobound(n). */
1212 coindex = fold_convert (gfc_array_index_type,
1213 gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
1215 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
1216 coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
1217 fold_convert (gfc_array_index_type, coindex),
1220 for (codim = corank + rank - 2; codim >= rank; codim--)
1222 tree extent, ubound;
1224 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1225 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1226 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
1227 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1229 /* coindex *= extent. */
1230 coindex = fold_build2_loc (input_location, MULT_EXPR,
1231 gfc_array_index_type, coindex, extent);
1233 /* coindex += sub(codim). */
1234 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
1235 coindex = fold_build2_loc (input_location, PLUS_EXPR,
1236 gfc_array_index_type, coindex,
1237 fold_convert (gfc_array_index_type, tmp));
1239 /* coindex -= lbound(codim). */
1240 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1241 coindex = fold_build2_loc (input_location, MINUS_EXPR,
1242 gfc_array_index_type, coindex, lbound);
1245 coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
1246 fold_convert(type, coindex),
1247 build_int_cst (type, 1));
1249 /* Return 0 if "coindex" exceeds num_images(). */
1251 if (gfc_option.coarray == GFC_FCOARRAY_SINGLE)
1252 num_images = build_int_cst (type, 1);
1255 gfc_init_coarray_decl (false);
1256 num_images = gfort_gvar_caf_num_images;
1259 tmp = gfc_create_var (type, NULL);
1260 gfc_add_modify (&se->pre, tmp, coindex);
1262 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
1264 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
1266 fold_convert (boolean_type_node, invalid_bound));
1267 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
1268 build_int_cst (type, 0), tmp);
1273 trans_num_images (gfc_se * se)
1275 gfc_init_coarray_decl (false);
1276 se->expr = gfort_gvar_caf_num_images;
1280 /* Evaluate a single upper or lower bound. */
1281 /* TODO: bound intrinsic generates way too much unnecessary code. */
1284 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
1286 gfc_actual_arglist *arg;
1287 gfc_actual_arglist *arg2;
1292 tree cond, cond1, cond3, cond4, size;
1297 gfc_array_spec * as;
1299 arg = expr->value.function.actual;
1304 /* Create an implicit second parameter from the loop variable. */
1305 gcc_assert (!arg2->expr);
1306 gcc_assert (se->loop->dimen == 1);
1307 gcc_assert (se->ss->expr == expr);
1308 gfc_advance_se_ss_chain (se);
1309 bound = se->loop->loopvar[0];
1310 bound = fold_build2_loc (input_location, MINUS_EXPR,
1311 gfc_array_index_type, bound,
1316 /* use the passed argument. */
1317 gcc_assert (arg2->expr);
1318 gfc_init_se (&argse, NULL);
1319 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
1320 gfc_add_block_to_block (&se->pre, &argse.pre);
1322 /* Convert from one based to zero based. */
1323 bound = fold_build2_loc (input_location, MINUS_EXPR,
1324 gfc_array_index_type, bound,
1325 gfc_index_one_node);
1328 /* TODO: don't re-evaluate the descriptor on each iteration. */
1329 /* Get a descriptor for the first parameter. */
1330 ss = gfc_walk_expr (arg->expr);
1331 gcc_assert (ss != gfc_ss_terminator);
1332 gfc_init_se (&argse, NULL);
1333 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
1334 gfc_add_block_to_block (&se->pre, &argse.pre);
1335 gfc_add_block_to_block (&se->post, &argse.post);
1339 if (INTEGER_CST_P (bound))
1343 hi = TREE_INT_CST_HIGH (bound);
1344 low = TREE_INT_CST_LOW (bound);
1345 if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
1346 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1347 "dimension index", upper ? "UBOUND" : "LBOUND",
1352 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1354 bound = gfc_evaluate_now (bound, &se->pre);
1355 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1356 bound, build_int_cst (TREE_TYPE (bound), 0));
1357 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
1358 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1360 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1361 boolean_type_node, cond, tmp);
1362 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1367 ubound = gfc_conv_descriptor_ubound_get (desc, bound);
1368 lbound = gfc_conv_descriptor_lbound_get (desc, bound);
1370 as = gfc_get_full_arrayspec_from_expr (arg->expr);
1372 /* 13.14.53: Result value for LBOUND
1374 Case (i): For an array section or for an array expression other than a
1375 whole array or array structure component, LBOUND(ARRAY, DIM)
1376 has the value 1. For a whole array or array structure
1377 component, LBOUND(ARRAY, DIM) has the value:
1378 (a) equal to the lower bound for subscript DIM of ARRAY if
1379 dimension DIM of ARRAY does not have extent zero
1380 or if ARRAY is an assumed-size array of rank DIM,
1383 13.14.113: Result value for UBOUND
1385 Case (i): For an array section or for an array expression other than a
1386 whole array or array structure component, UBOUND(ARRAY, DIM)
1387 has the value equal to the number of elements in the given
1388 dimension; otherwise, it has a value equal to the upper bound
1389 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1390 not have size zero and has value zero if dimension DIM has
1395 tree stride = gfc_conv_descriptor_stride_get (desc, bound);
1397 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1399 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1400 stride, gfc_index_zero_node);
1401 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1402 boolean_type_node, cond3, cond1);
1403 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1404 stride, gfc_index_zero_node);
1409 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1410 boolean_type_node, cond3, cond4);
1411 cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1412 gfc_index_one_node, lbound);
1413 cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1414 boolean_type_node, cond4, cond5);
1416 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1417 boolean_type_node, cond, cond5);
1419 se->expr = fold_build3_loc (input_location, COND_EXPR,
1420 gfc_array_index_type, cond,
1421 ubound, gfc_index_zero_node);
1425 if (as->type == AS_ASSUMED_SIZE)
1426 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1427 bound, build_int_cst (TREE_TYPE (bound),
1428 arg->expr->rank - 1));
1430 cond = boolean_false_node;
1432 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1433 boolean_type_node, cond3, cond4);
1434 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1435 boolean_type_node, cond, cond1);
1437 se->expr = fold_build3_loc (input_location, COND_EXPR,
1438 gfc_array_index_type, cond,
1439 lbound, gfc_index_one_node);
1446 size = fold_build2_loc (input_location, MINUS_EXPR,
1447 gfc_array_index_type, ubound, lbound);
1448 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
1449 gfc_array_index_type, size,
1450 gfc_index_one_node);
1451 se->expr = fold_build2_loc (input_location, MAX_EXPR,
1452 gfc_array_index_type, se->expr,
1453 gfc_index_zero_node);
1456 se->expr = gfc_index_one_node;
1459 type = gfc_typenode_for_spec (&expr->ts);
1460 se->expr = convert (type, se->expr);
1465 conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
1467 gfc_actual_arglist *arg;
1468 gfc_actual_arglist *arg2;
1471 tree bound, resbound, resbound2, desc, cond, tmp;
1475 gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
1476 || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
1477 || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
1479 arg = expr->value.function.actual;
1482 gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
1483 corank = gfc_get_corank (arg->expr);
1485 if (expr->value.function.actual->expr->rank == 0)
1486 convert_element_to_coarray_ref (expr->value.function.actual->expr);
1487 ss = gfc_walk_expr (arg->expr);
1488 gcc_assert (ss != gfc_ss_terminator);
1489 ss->data.info.codimen = corank;
1490 gfc_init_se (&argse, NULL);
1492 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
1493 gfc_add_block_to_block (&se->pre, &argse.pre);
1494 gfc_add_block_to_block (&se->post, &argse.post);
1499 /* Create an implicit second parameter from the loop variable. */
1500 gcc_assert (!arg2->expr);
1501 gcc_assert (corank > 0);
1502 gcc_assert (se->loop->dimen == 1);
1503 gcc_assert (se->ss->expr == expr);
1505 bound = se->loop->loopvar[0];
1506 bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1507 bound, gfc_rank_cst[arg->expr->rank]);
1508 gfc_advance_se_ss_chain (se);
1512 /* use the passed argument. */
1513 gcc_assert (arg2->expr);
1514 gfc_init_se (&argse, NULL);
1515 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
1516 gfc_add_block_to_block (&se->pre, &argse.pre);
1519 if (INTEGER_CST_P (bound))
1523 hi = TREE_INT_CST_HIGH (bound);
1524 low = TREE_INT_CST_LOW (bound);
1525 if (hi || low < 1 || low > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
1526 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1527 "dimension index", expr->value.function.isym->name,
1530 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1532 bound = gfc_evaluate_now (bound, &se->pre);
1533 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1534 bound, build_int_cst (TREE_TYPE (bound), 1));
1535 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
1536 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1538 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1539 boolean_type_node, cond, tmp);
1540 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1545 /* Substract 1 to get to zero based and add dimensions. */
1546 switch (arg->expr->rank)
1549 bound = fold_build2_loc (input_location, MINUS_EXPR,
1550 gfc_array_index_type, bound,
1551 gfc_index_one_node);
1555 bound = fold_build2_loc (input_location, PLUS_EXPR,
1556 gfc_array_index_type, bound,
1557 gfc_rank_cst[arg->expr->rank - 1]);
1561 resbound = gfc_conv_descriptor_lbound_get (desc, bound);
1563 /* Handle UCOBOUND with special handling of the last codimension. */
1564 if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
1566 /* Last codimension: For -fcoarray=single just return
1567 the lcobound - otherwise add
1568 ceiling (real (num_images ()) / real (size)) - 1
1569 = (num_images () + size - 1) / size - 1
1570 = (num_images - 1) / size(),
1571 where size is the product of the extent of all but the last
1574 if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && corank > 1)
1578 gfc_init_coarray_decl (false);
1579 cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
1581 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1582 gfc_array_index_type,
1583 gfort_gvar_caf_num_images,
1584 build_int_cst (gfc_array_index_type, 1));
1585 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1586 gfc_array_index_type, tmp,
1587 fold_convert (gfc_array_index_type, cosize));
1588 resbound = fold_build2_loc (input_location, PLUS_EXPR,
1589 gfc_array_index_type, resbound, tmp);
1591 else if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
1593 /* ubound = lbound + num_images() - 1. */
1594 gfc_init_coarray_decl (false);
1595 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1596 gfc_array_index_type,
1597 gfort_gvar_caf_num_images,
1598 build_int_cst (gfc_array_index_type, 1));
1599 resbound = fold_build2_loc (input_location, PLUS_EXPR,
1600 gfc_array_index_type, resbound, tmp);
1605 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1607 build_int_cst (TREE_TYPE (bound),
1608 arg->expr->rank + corank - 1));
1610 resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
1611 se->expr = fold_build3_loc (input_location, COND_EXPR,
1612 gfc_array_index_type, cond,
1613 resbound, resbound2);
1616 se->expr = resbound;
1619 se->expr = resbound;
1621 type = gfc_typenode_for_spec (&expr->ts);
1622 se->expr = convert (type, se->expr);
1627 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
1631 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1633 switch (expr->value.function.actual->expr->ts.type)
1637 se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
1642 cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
1643 se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
1652 /* Create a complex value from one or two real components. */
1655 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1661 unsigned int num_args;
1663 num_args = gfc_intrinsic_argument_list_length (expr);
1664 args = XALLOCAVEC (tree, num_args);
1666 type = gfc_typenode_for_spec (&expr->ts);
1667 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1668 real = convert (TREE_TYPE (type), args[0]);
1670 imag = convert (TREE_TYPE (type), args[1]);
1671 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1673 imag = fold_build1_loc (input_location, IMAGPART_EXPR,
1674 TREE_TYPE (TREE_TYPE (args[0])), args[0]);
1675 imag = convert (TREE_TYPE (type), imag);
1678 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1680 se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
1683 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1684 MODULO(A, P) = A - FLOOR (A / P) * P */
1685 /* TODO: MOD(x, 0) */
1688 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1700 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1702 switch (expr->ts.type)
1705 /* Integer case is easy, we've got a builtin op. */
1706 type = TREE_TYPE (args[0]);
1709 se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
1712 se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
1718 /* Check if we have a builtin fmod. */
1719 fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
1721 /* Use it if it exists. */
1722 if (fmod != NULL_TREE)
1724 tmp = build_addr (fmod, current_function_decl);
1725 se->expr = build_call_array_loc (input_location,
1726 TREE_TYPE (TREE_TYPE (fmod)),
1732 type = TREE_TYPE (args[0]);
1734 args[0] = gfc_evaluate_now (args[0], &se->pre);
1735 args[1] = gfc_evaluate_now (args[1], &se->pre);
1738 modulo = arg - floor (arg/arg2) * arg2, so
1739 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1741 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1742 thereby avoiding another division and retaining the accuracy
1743 of the builtin function. */
1744 if (fmod != NULL_TREE && modulo)
1746 tree zero = gfc_build_const (type, integer_zero_node);
1747 tmp = gfc_evaluate_now (se->expr, &se->pre);
1748 test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1750 test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1752 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
1753 boolean_type_node, test, test2);
1754 test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1756 test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1757 boolean_type_node, test, test2);
1758 test = gfc_evaluate_now (test, &se->pre);
1759 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
1760 fold_build2_loc (input_location, PLUS_EXPR,
1761 type, tmp, args[1]), tmp);
1765 /* If we do not have a built_in fmod, the calculation is going to
1766 have to be done longhand. */
1767 tmp = fold_build2_loc (input_location, RDIV_EXPR, type, args[0], args[1]);
1769 /* Test if the value is too large to handle sensibly. */
1770 gfc_set_model_kind (expr->ts.kind);
1772 n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1773 ikind = expr->ts.kind;
1776 n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1777 ikind = gfc_max_integer_kind;
1779 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1780 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1781 test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1784 mpfr_neg (huge, huge, GFC_RND_MODE);
1785 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1786 test = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
1788 test2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1789 boolean_type_node, test, test2);
1791 itype = gfc_get_int_type (ikind);
1793 tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1795 tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1796 tmp = convert (type, tmp);
1797 tmp = fold_build3_loc (input_location, COND_EXPR, type, test2, tmp,
1799 tmp = fold_build2_loc (input_location, MULT_EXPR, type, tmp, args[1]);
1800 se->expr = fold_build2_loc (input_location, MINUS_EXPR, type, args[0],
1810 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
1811 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
1812 where the right shifts are logical (i.e. 0's are shifted in).
1813 Because SHIFT_EXPR's want shifts strictly smaller than the integral
1814 type width, we have to special-case both S == 0 and S == BITSIZE(J):
1816 DSHIFTL(I,J,BITSIZE) = J
1818 DSHIFTR(I,J,BITSIZE) = I. */
1821 gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
1823 tree type, utype, stype, arg1, arg2, shift, res, left, right;
1824 tree args[3], cond, tmp;
1827 gfc_conv_intrinsic_function_args (se, expr, args, 3);
1829 gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
1830 type = TREE_TYPE (args[0]);
1831 bitsize = TYPE_PRECISION (type);
1832 utype = unsigned_type_for (type);
1833 stype = TREE_TYPE (args[2]);
1835 arg1 = gfc_evaluate_now (args[0], &se->pre);
1836 arg2 = gfc_evaluate_now (args[1], &se->pre);
1837 shift = gfc_evaluate_now (args[2], &se->pre);
1839 /* The generic case. */
1840 tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
1841 build_int_cst (stype, bitsize), shift);
1842 left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
1843 arg1, dshiftl ? shift : tmp);
1845 right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
1846 fold_convert (utype, arg2), dshiftl ? tmp : shift);
1847 right = fold_convert (type, right);
1849 res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
1851 /* Special cases. */
1852 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
1853 build_int_cst (stype, 0));
1854 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
1855 dshiftl ? arg1 : arg2, res);
1857 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
1858 build_int_cst (stype, bitsize));
1859 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
1860 dshiftl ? arg2 : arg1, res);
1866 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1869 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1877 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1878 type = TREE_TYPE (args[0]);
1880 val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
1881 val = gfc_evaluate_now (val, &se->pre);
1883 zero = gfc_build_const (type, integer_zero_node);
1884 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, val, zero);
1885 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
1889 /* SIGN(A, B) is absolute value of A times sign of B.
1890 The real value versions use library functions to ensure the correct
1891 handling of negative zero. Integer case implemented as:
1892 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1896 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1902 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1903 if (expr->ts.type == BT_REAL)
1907 tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
1908 abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
1910 /* We explicitly have to ignore the minus sign. We do so by using
1911 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1912 if (!gfc_option.flag_sign_zero
1913 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
1916 zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
1917 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1919 se->expr = fold_build3_loc (input_location, COND_EXPR,
1920 TREE_TYPE (args[0]), cond,
1921 build_call_expr_loc (input_location, abs, 1,
1923 build_call_expr_loc (input_location, tmp, 2,
1927 se->expr = build_call_expr_loc (input_location, tmp, 2,
1932 /* Having excluded floating point types, we know we are now dealing
1933 with signed integer types. */
1934 type = TREE_TYPE (args[0]);
1936 /* Args[0] is used multiple times below. */
1937 args[0] = gfc_evaluate_now (args[0], &se->pre);
1939 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1940 the signs of A and B are the same, and of all ones if they differ. */
1941 tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
1942 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
1943 build_int_cst (type, TYPE_PRECISION (type) - 1));
1944 tmp = gfc_evaluate_now (tmp, &se->pre);
1946 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1947 is all ones (i.e. -1). */
1948 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
1949 fold_build2_loc (input_location, PLUS_EXPR,
1950 type, args[0], tmp), tmp);
1954 /* Test for the presence of an optional argument. */
1957 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1961 arg = expr->value.function.actual->expr;
1962 gcc_assert (arg->expr_type == EXPR_VARIABLE);
1963 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1964 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1968 /* Calculate the double precision product of two single precision values. */
1971 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1976 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1978 /* Convert the args to double precision before multiplying. */
1979 type = gfc_typenode_for_spec (&expr->ts);
1980 args[0] = convert (type, args[0]);
1981 args[1] = convert (type, args[1]);
1982 se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
1987 /* Return a length one character string containing an ascii character. */
1990 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1995 unsigned int num_args;
1997 num_args = gfc_intrinsic_argument_list_length (expr);
1998 gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
2000 type = gfc_get_char_type (expr->ts.kind);
2001 var = gfc_create_var (type, "char");
2003 arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
2004 gfc_add_modify (&se->pre, var, arg[0]);
2005 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
2006 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
2011 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
2019 unsigned int num_args;
2021 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2022 args = XALLOCAVEC (tree, num_args);
2024 var = gfc_create_var (pchar_type_node, "pstr");
2025 len = gfc_create_var (gfc_charlen_type_node, "len");
2027 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2028 args[0] = gfc_build_addr_expr (NULL_TREE, var);
2029 args[1] = gfc_build_addr_expr (NULL_TREE, len);
2031 fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
2032 tmp = build_call_array_loc (input_location,
2033 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
2034 fndecl, num_args, args);
2035 gfc_add_expr_to_block (&se->pre, tmp);
2037 /* Free the temporary afterwards, if necessary. */
2038 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2039 len, build_int_cst (TREE_TYPE (len), 0));
2040 tmp = gfc_call_free (var);
2041 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2042 gfc_add_expr_to_block (&se->post, tmp);
2045 se->string_length = len;
2050 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
2058 unsigned int num_args;
2060 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2061 args = XALLOCAVEC (tree, num_args);
2063 var = gfc_create_var (pchar_type_node, "pstr");
2064 len = gfc_create_var (gfc_charlen_type_node, "len");
2066 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2067 args[0] = gfc_build_addr_expr (NULL_TREE, var);
2068 args[1] = gfc_build_addr_expr (NULL_TREE, len);
2070 fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
2071 tmp = build_call_array_loc (input_location,
2072 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
2073 fndecl, num_args, args);
2074 gfc_add_expr_to_block (&se->pre, tmp);
2076 /* Free the temporary afterwards, if necessary. */
2077 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2078 len, build_int_cst (TREE_TYPE (len), 0));
2079 tmp = gfc_call_free (var);
2080 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2081 gfc_add_expr_to_block (&se->post, tmp);
2084 se->string_length = len;
2088 /* Return a character string containing the tty name. */
2091 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
2099 unsigned int num_args;
2101 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2102 args = XALLOCAVEC (tree, num_args);
2104 var = gfc_create_var (pchar_type_node, "pstr");
2105 len = gfc_create_var (gfc_charlen_type_node, "len");
2107 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2108 args[0] = gfc_build_addr_expr (NULL_TREE, var);
2109 args[1] = gfc_build_addr_expr (NULL_TREE, len);
2111 fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
2112 tmp = build_call_array_loc (input_location,
2113 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
2114 fndecl, num_args, args);
2115 gfc_add_expr_to_block (&se->pre, tmp);
2117 /* Free the temporary afterwards, if necessary. */
2118 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2119 len, build_int_cst (TREE_TYPE (len), 0));
2120 tmp = gfc_call_free (var);
2121 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2122 gfc_add_expr_to_block (&se->post, tmp);
2125 se->string_length = len;
2129 /* Get the minimum/maximum value of all the parameters.
2130 minmax (a1, a2, a3, ...)
2133 if (a2 .op. mvar || isnan(mvar))
2135 if (a3 .op. mvar || isnan(mvar))
2142 /* TODO: Mismatching types can occur when specific names are used.
2143 These should be handled during resolution. */
2145 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
2153 gfc_actual_arglist *argexpr;
2154 unsigned int i, nargs;
2156 nargs = gfc_intrinsic_argument_list_length (expr);
2157 args = XALLOCAVEC (tree, nargs);
2159 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
2160 type = gfc_typenode_for_spec (&expr->ts);
2162 argexpr = expr->value.function.actual;
2163 if (TREE_TYPE (args[0]) != type)
2164 args[0] = convert (type, args[0]);
2165 /* Only evaluate the argument once. */
2166 if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
2167 args[0] = gfc_evaluate_now (args[0], &se->pre);
2169 mvar = gfc_create_var (type, "M");
2170 gfc_add_modify (&se->pre, mvar, args[0]);
2171 for (i = 1, argexpr = argexpr->next; i < nargs; i++)
2177 /* Handle absent optional arguments by ignoring the comparison. */
2178 if (argexpr->expr->expr_type == EXPR_VARIABLE
2179 && argexpr->expr->symtree->n.sym->attr.optional
2180 && TREE_CODE (val) == INDIRECT_REF)
2181 cond = fold_build2_loc (input_location,
2182 NE_EXPR, boolean_type_node,
2183 TREE_OPERAND (val, 0),
2184 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
2189 /* Only evaluate the argument once. */
2190 if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
2191 val = gfc_evaluate_now (val, &se->pre);
2194 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
2196 tmp = fold_build2_loc (input_location, op, boolean_type_node,
2197 convert (type, val), mvar);
2199 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2200 __builtin_isnan might be made dependent on that module being loaded,
2201 to help performance of programs that don't rely on IEEE semantics. */
2202 if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
2204 isnan = build_call_expr_loc (input_location,
2205 built_in_decls[BUILT_IN_ISNAN], 1, mvar);
2206 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2207 boolean_type_node, tmp,
2208 fold_convert (boolean_type_node, isnan));
2210 tmp = build3_v (COND_EXPR, tmp, thencase,
2211 build_empty_stmt (input_location));
2213 if (cond != NULL_TREE)
2214 tmp = build3_v (COND_EXPR, cond, tmp,
2215 build_empty_stmt (input_location));
2217 gfc_add_expr_to_block (&se->pre, tmp);
2218 argexpr = argexpr->next;
2224 /* Generate library calls for MIN and MAX intrinsics for character
2227 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
2230 tree var, len, fndecl, tmp, cond, function;
2233 nargs = gfc_intrinsic_argument_list_length (expr);
2234 args = XALLOCAVEC (tree, nargs + 4);
2235 gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
2237 /* Create the result variables. */
2238 len = gfc_create_var (gfc_charlen_type_node, "len");
2239 args[0] = gfc_build_addr_expr (NULL_TREE, len);
2240 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
2241 args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
2242 args[2] = build_int_cst (integer_type_node, op);
2243 args[3] = build_int_cst (integer_type_node, nargs / 2);
2245 if (expr->ts.kind == 1)
2246 function = gfor_fndecl_string_minmax;
2247 else if (expr->ts.kind == 4)
2248 function = gfor_fndecl_string_minmax_char4;
2252 /* Make the function call. */
2253 fndecl = build_addr (function, current_function_decl);
2254 tmp = build_call_array_loc (input_location,
2255 TREE_TYPE (TREE_TYPE (function)), fndecl,
2257 gfc_add_expr_to_block (&se->pre, tmp);
2259 /* Free the temporary afterwards, if necessary. */
2260 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2261 len, build_int_cst (TREE_TYPE (len), 0));
2262 tmp = gfc_call_free (var);
2263 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2264 gfc_add_expr_to_block (&se->post, tmp);
2267 se->string_length = len;
2271 /* Create a symbol node for this intrinsic. The symbol from the frontend
2272 has the generic name. */
2275 gfc_get_symbol_for_expr (gfc_expr * expr)
2279 /* TODO: Add symbols for intrinsic function to the global namespace. */
2280 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
2281 sym = gfc_new_symbol (expr->value.function.name, NULL);
2284 sym->attr.external = 1;
2285 sym->attr.function = 1;
2286 sym->attr.always_explicit = 1;
2287 sym->attr.proc = PROC_INTRINSIC;
2288 sym->attr.flavor = FL_PROCEDURE;
2292 sym->attr.dimension = 1;
2293 sym->as = gfc_get_array_spec ();
2294 sym->as->type = AS_ASSUMED_SHAPE;
2295 sym->as->rank = expr->rank;
2298 gfc_copy_formal_args_intr (sym, expr->value.function.isym);
2303 /* Generate a call to an external intrinsic function. */
2305 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
2308 VEC(tree,gc) *append_args;
2310 gcc_assert (!se->ss || se->ss->expr == expr);
2313 gcc_assert (expr->rank > 0);
2315 gcc_assert (expr->rank == 0);
2317 sym = gfc_get_symbol_for_expr (expr);
2319 /* Calls to libgfortran_matmul need to be appended special arguments,
2320 to be able to call the BLAS ?gemm functions if required and possible. */
2322 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
2323 && sym->ts.type != BT_LOGICAL)
2325 tree cint = gfc_get_int_type (gfc_c_int_kind);
2327 if (gfc_option.flag_external_blas
2328 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
2329 && (sym->ts.kind == gfc_default_real_kind
2330 || sym->ts.kind == gfc_default_double_kind))
2334 if (sym->ts.type == BT_REAL)
2336 if (sym->ts.kind == gfc_default_real_kind)
2337 gemm_fndecl = gfor_fndecl_sgemm;
2339 gemm_fndecl = gfor_fndecl_dgemm;
2343 if (sym->ts.kind == gfc_default_real_kind)
2344 gemm_fndecl = gfor_fndecl_cgemm;
2346 gemm_fndecl = gfor_fndecl_zgemm;
2349 append_args = VEC_alloc (tree, gc, 3);
2350 VEC_quick_push (tree, append_args, build_int_cst (cint, 1));
2351 VEC_quick_push (tree, append_args,
2352 build_int_cst (cint, gfc_option.blas_matmul_limit));
2353 VEC_quick_push (tree, append_args,
2354 gfc_build_addr_expr (NULL_TREE, gemm_fndecl));
2358 append_args = VEC_alloc (tree, gc, 3);
2359 VEC_quick_push (tree, append_args, build_int_cst (cint, 0));
2360 VEC_quick_push (tree, append_args, build_int_cst (cint, 0));
2361 VEC_quick_push (tree, append_args, null_pointer_node);
2365 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
2367 gfc_free_symbol (sym);
2370 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
2390 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
2399 gfc_actual_arglist *actual;
2406 gfc_conv_intrinsic_funcall (se, expr);
2410 actual = expr->value.function.actual;
2411 type = gfc_typenode_for_spec (&expr->ts);
2412 /* Initialize the result. */
2413 resvar = gfc_create_var (type, "test");
2415 tmp = convert (type, boolean_true_node);
2417 tmp = convert (type, boolean_false_node);
2418 gfc_add_modify (&se->pre, resvar, tmp);
2420 /* Walk the arguments. */
2421 arrayss = gfc_walk_expr (actual->expr);
2422 gcc_assert (arrayss != gfc_ss_terminator);
2424 /* Initialize the scalarizer. */
2425 gfc_init_loopinfo (&loop);
2426 exit_label = gfc_build_label_decl (NULL_TREE);
2427 TREE_USED (exit_label) = 1;
2428 gfc_add_ss_to_loop (&loop, arrayss);
2430 /* Initialize the loop. */
2431 gfc_conv_ss_startstride (&loop);
2432 gfc_conv_loop_setup (&loop, &expr->where);
2434 gfc_mark_ss_chain_used (arrayss, 1);
2435 /* Generate the loop body. */
2436 gfc_start_scalarized_body (&loop, &body);
2438 /* If the condition matches then set the return value. */
2439 gfc_start_block (&block);
2441 tmp = convert (type, boolean_false_node);
2443 tmp = convert (type, boolean_true_node);
2444 gfc_add_modify (&block, resvar, tmp);
2446 /* And break out of the loop. */
2447 tmp = build1_v (GOTO_EXPR, exit_label);
2448 gfc_add_expr_to_block (&block, tmp);
2450 found = gfc_finish_block (&block);
2452 /* Check this element. */
2453 gfc_init_se (&arrayse, NULL);
2454 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2455 arrayse.ss = arrayss;
2456 gfc_conv_expr_val (&arrayse, actual->expr);
2458 gfc_add_block_to_block (&body, &arrayse.pre);
2459 tmp = fold_build2_loc (input_location, op, boolean_type_node, arrayse.expr,
2460 build_int_cst (TREE_TYPE (arrayse.expr), 0));
2461 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
2462 gfc_add_expr_to_block (&body, tmp);
2463 gfc_add_block_to_block (&body, &arrayse.post);
2465 gfc_trans_scalarizing_loops (&loop, &body);
2467 /* Add the exit label. */
2468 tmp = build1_v (LABEL_EXPR, exit_label);
2469 gfc_add_expr_to_block (&loop.pre, tmp);
2471 gfc_add_block_to_block (&se->pre, &loop.pre);
2472 gfc_add_block_to_block (&se->pre, &loop.post);
2473 gfc_cleanup_loop (&loop);
2478 /* COUNT(A) = Number of true elements in A. */
2480 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
2487 gfc_actual_arglist *actual;
2493 gfc_conv_intrinsic_funcall (se, expr);
2497 actual = expr->value.function.actual;
2499 type = gfc_typenode_for_spec (&expr->ts);
2500 /* Initialize the result. */
2501 resvar = gfc_create_var (type, "count");
2502 gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
2504 /* Walk the arguments. */
2505 arrayss = gfc_walk_expr (actual->expr);
2506 gcc_assert (arrayss != gfc_ss_terminator);
2508 /* Initialize the scalarizer. */
2509 gfc_init_loopinfo (&loop);
2510 gfc_add_ss_to_loop (&loop, arrayss);
2512 /* Initialize the loop. */
2513 gfc_conv_ss_startstride (&loop);
2514 gfc_conv_loop_setup (&loop, &expr->where);
2516 gfc_mark_ss_chain_used (arrayss, 1);
2517 /* Generate the loop body. */
2518 gfc_start_scalarized_body (&loop, &body);
2520 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
2521 resvar, build_int_cst (TREE_TYPE (resvar), 1));
2522 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
2524 gfc_init_se (&arrayse, NULL);
2525 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2526 arrayse.ss = arrayss;
2527 gfc_conv_expr_val (&arrayse, actual->expr);
2528 tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
2529 build_empty_stmt (input_location));
2531 gfc_add_block_to_block (&body, &arrayse.pre);
2532 gfc_add_expr_to_block (&body, tmp);
2533 gfc_add_block_to_block (&body, &arrayse.post);
2535 gfc_trans_scalarizing_loops (&loop, &body);
2537 gfc_add_block_to_block (&se->pre, &loop.pre);
2538 gfc_add_block_to_block (&se->pre, &loop.post);
2539 gfc_cleanup_loop (&loop);
2544 /* Inline implementation of the sum and product intrinsics. */
2546 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
2550 tree scale = NULL_TREE;
2556 gfc_actual_arglist *actual;
2561 gfc_expr *arrayexpr;
2566 gfc_conv_intrinsic_funcall (se, expr);
2570 type = gfc_typenode_for_spec (&expr->ts);
2571 /* Initialize the result. */
2572 resvar = gfc_create_var (type, "val");
2577 scale = gfc_create_var (type, "scale");
2578 gfc_add_modify (&se->pre, scale,
2579 gfc_build_const (type, integer_one_node));
2580 tmp = gfc_build_const (type, integer_zero_node);
2582 else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
2583 tmp = gfc_build_const (type, integer_zero_node);
2584 else if (op == NE_EXPR)
2586 tmp = convert (type, boolean_false_node);
2587 else if (op == BIT_AND_EXPR)
2588 tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
2589 type, integer_one_node));
2591 tmp = gfc_build_const (type, integer_one_node);
2593 gfc_add_modify (&se->pre, resvar, tmp);
2595 /* Walk the arguments. */
2596 actual = expr->value.function.actual;
2597 arrayexpr = actual->expr;
2598 arrayss = gfc_walk_expr (arrayexpr);
2599 gcc_assert (arrayss != gfc_ss_terminator);
2601 if (op == NE_EXPR || norm2)
2602 /* PARITY and NORM2. */
2606 actual = actual->next->next;
2607 gcc_assert (actual);
2608 maskexpr = actual->expr;
2611 if (maskexpr && maskexpr->rank != 0)
2613 maskss = gfc_walk_expr (maskexpr);
2614 gcc_assert (maskss != gfc_ss_terminator);
2619 /* Initialize the scalarizer. */
2620 gfc_init_loopinfo (&loop);
2621 gfc_add_ss_to_loop (&loop, arrayss);
2623 gfc_add_ss_to_loop (&loop, maskss);
2625 /* Initialize the loop. */
2626 gfc_conv_ss_startstride (&loop);
2627 gfc_conv_loop_setup (&loop, &expr->where);
2629 gfc_mark_ss_chain_used (arrayss, 1);
2631 gfc_mark_ss_chain_used (maskss, 1);
2632 /* Generate the loop body. */
2633 gfc_start_scalarized_body (&loop, &body);
2635 /* If we have a mask, only add this element if the mask is set. */
2638 gfc_init_se (&maskse, NULL);
2639 gfc_copy_loopinfo_to_se (&maskse, &loop);
2641 gfc_conv_expr_val (&maskse, maskexpr);
2642 gfc_add_block_to_block (&body, &maskse.pre);
2644 gfc_start_block (&block);
2647 gfc_init_block (&block);
2649 /* Do the actual summation/product. */
2650 gfc_init_se (&arrayse, NULL);
2651 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2652 arrayse.ss = arrayss;
2653 gfc_conv_expr_val (&arrayse, arrayexpr);
2654 gfc_add_block_to_block (&block, &arrayse.pre);
2664 result = 1.0 + result * val * val;
2670 result += val * val;
2673 tree res1, res2, cond, absX, val;
2674 stmtblock_t ifblock1, ifblock2, ifblock3;
2676 gfc_init_block (&ifblock1);
2678 absX = gfc_create_var (type, "absX");
2679 gfc_add_modify (&ifblock1, absX,
2680 fold_build1_loc (input_location, ABS_EXPR, type,
2682 val = gfc_create_var (type, "val");
2683 gfc_add_expr_to_block (&ifblock1, val);
2685 gfc_init_block (&ifblock2);
2686 gfc_add_modify (&ifblock2, val,
2687 fold_build2_loc (input_location, RDIV_EXPR, type, scale,
2689 res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
2690 res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
2691 res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
2692 gfc_build_const (type, integer_one_node));
2693 gfc_add_modify (&ifblock2, resvar, res1);
2694 gfc_add_modify (&ifblock2, scale, absX);
2695 res1 = gfc_finish_block (&ifblock2);
2697 gfc_init_block (&ifblock3);
2698 gfc_add_modify (&ifblock3, val,
2699 fold_build2_loc (input_location, RDIV_EXPR, type, absX,
2701 res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
2702 res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
2703 gfc_add_modify (&ifblock3, resvar, res2);
2704 res2 = gfc_finish_block (&ifblock3);
2706 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2708 tmp = build3_v (COND_EXPR, cond, res1, res2);
2709 gfc_add_expr_to_block (&ifblock1, tmp);
2710 tmp = gfc_finish_block (&ifblock1);
2712 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2714 gfc_build_const (type, integer_zero_node));
2716 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2717 gfc_add_expr_to_block (&block, tmp);
2721 tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
2722 gfc_add_modify (&block, resvar, tmp);
2725 gfc_add_block_to_block (&block, &arrayse.post);
2729 /* We enclose the above in if (mask) {...} . */
2731 tmp = gfc_finish_block (&block);
2732 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2733 build_empty_stmt (input_location));
2736 tmp = gfc_finish_block (&block);
2737 gfc_add_expr_to_block (&body, tmp);
2739 gfc_trans_scalarizing_loops (&loop, &body);
2741 /* For a scalar mask, enclose the loop in an if statement. */
2742 if (maskexpr && maskss == NULL)
2744 gfc_init_se (&maskse, NULL);
2745 gfc_conv_expr_val (&maskse, maskexpr);
2746 gfc_init_block (&block);
2747 gfc_add_block_to_block (&block, &loop.pre);
2748 gfc_add_block_to_block (&block, &loop.post);
2749 tmp = gfc_finish_block (&block);
2751 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2752 build_empty_stmt (input_location));
2753 gfc_add_expr_to_block (&block, tmp);
2754 gfc_add_block_to_block (&se->pre, &block);
2758 gfc_add_block_to_block (&se->pre, &loop.pre);
2759 gfc_add_block_to_block (&se->pre, &loop.post);
2762 gfc_cleanup_loop (&loop);
2766 /* result = scale * sqrt(result). */
2768 sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
2769 resvar = build_call_expr_loc (input_location,
2771 resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
2778 /* Inline implementation of the dot_product intrinsic. This function
2779 is based on gfc_conv_intrinsic_arith (the previous function). */
2781 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2789 gfc_actual_arglist *actual;
2790 gfc_ss *arrayss1, *arrayss2;
2791 gfc_se arrayse1, arrayse2;
2792 gfc_expr *arrayexpr1, *arrayexpr2;
2794 type = gfc_typenode_for_spec (&expr->ts);
2796 /* Initialize the result. */
2797 resvar = gfc_create_var (type, "val");
2798 if (expr->ts.type == BT_LOGICAL)
2799 tmp = build_int_cst (type, 0);
2801 tmp = gfc_build_const (type, integer_zero_node);
2803 gfc_add_modify (&se->pre, resvar, tmp);
2805 /* Walk argument #1. */
2806 actual = expr->value.function.actual;
2807 arrayexpr1 = actual->expr;
2808 arrayss1 = gfc_walk_expr (arrayexpr1);
2809 gcc_assert (arrayss1 != gfc_ss_terminator);
2811 /* Walk argument #2. */
2812 actual = actual->next;
2813 arrayexpr2 = actual->expr;
2814 arrayss2 = gfc_walk_expr (arrayexpr2);
2815 gcc_assert (arrayss2 != gfc_ss_terminator);
2817 /* Initialize the scalarizer. */
2818 gfc_init_loopinfo (&loop);
2819 gfc_add_ss_to_loop (&loop, arrayss1);
2820 gfc_add_ss_to_loop (&loop, arrayss2);
2822 /* Initialize the loop. */
2823 gfc_conv_ss_startstride (&loop);
2824 gfc_conv_loop_setup (&loop, &expr->where);
2826 gfc_mark_ss_chain_used (arrayss1, 1);
2827 gfc_mark_ss_chain_used (arrayss2, 1);
2829 /* Generate the loop body. */
2830 gfc_start_scalarized_body (&loop, &body);
2831 gfc_init_block (&block);
2833 /* Make the tree expression for [conjg(]array1[)]. */
2834 gfc_init_se (&arrayse1, NULL);
2835 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2836 arrayse1.ss = arrayss1;
2837 gfc_conv_expr_val (&arrayse1, arrayexpr1);
2838 if (expr->ts.type == BT_COMPLEX)
2839 arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
2841 gfc_add_block_to_block (&block, &arrayse1.pre);
2843 /* Make the tree expression for array2. */
2844 gfc_init_se (&arrayse2, NULL);
2845 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2846 arrayse2.ss = arrayss2;
2847 gfc_conv_expr_val (&arrayse2, arrayexpr2);
2848 gfc_add_block_to_block (&block, &arrayse2.pre);
2850 /* Do the actual product and sum. */
2851 if (expr->ts.type == BT_LOGICAL)
2853 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
2854 arrayse1.expr, arrayse2.expr);
2855 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
2859 tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
2861 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
2863 gfc_add_modify (&block, resvar, tmp);
2865 /* Finish up the loop block and the loop. */
2866 tmp = gfc_finish_block (&block);
2867 gfc_add_expr_to_block (&body, tmp);
2869 gfc_trans_scalarizing_loops (&loop, &body);
2870 gfc_add_block_to_block (&se->pre, &loop.pre);
2871 gfc_add_block_to_block (&se->pre, &loop.post);
2872 gfc_cleanup_loop (&loop);
2878 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2879 we need to handle. For performance reasons we sometimes create two
2880 loops instead of one, where the second one is much simpler.
2881 Examples for minloc intrinsic:
2882 1) Result is an array, a call is generated
2883 2) Array mask is used and NaNs need to be supported:
2889 if (pos == 0) pos = S + (1 - from);
2890 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2897 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2901 3) NaNs need to be supported, but it is known at compile time or cheaply
2902 at runtime whether array is nonempty or not:
2907 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2910 if (from <= to) pos = 1;
2914 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2918 4) NaNs aren't supported, array mask is used:
2919 limit = infinities_supported ? Infinity : huge (limit);
2923 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2929 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2933 5) Same without array mask:
2934 limit = infinities_supported ? Infinity : huge (limit);
2935 pos = (from <= to) ? 1 : 0;
2938 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2941 For 3) and 5), if mask is scalar, this all goes into a conditional,
2942 setting pos = 0; in the else branch. */
2945 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
2949 stmtblock_t ifblock;
2950 stmtblock_t elseblock;
2961 gfc_actual_arglist *actual;
2966 gfc_expr *arrayexpr;
2973 gfc_conv_intrinsic_funcall (se, expr);
2977 /* Initialize the result. */
2978 pos = gfc_create_var (gfc_array_index_type, "pos");
2979 offset = gfc_create_var (gfc_array_index_type, "offset");
2980 type = gfc_typenode_for_spec (&expr->ts);
2982 /* Walk the arguments. */
2983 actual = expr->value.function.actual;
2984 arrayexpr = actual->expr;
2985 arrayss = gfc_walk_expr (arrayexpr);
2986 gcc_assert (arrayss != gfc_ss_terminator);
2988 actual = actual->next->next;
2989 gcc_assert (actual);
2990 maskexpr = actual->expr;
2992 if (maskexpr && maskexpr->rank != 0)
2994 maskss = gfc_walk_expr (maskexpr);
2995 gcc_assert (maskss != gfc_ss_terminator);
3000 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
3002 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
3004 nonempty = fold_build2_loc (input_location, GT_EXPR,
3005 boolean_type_node, nonempty,
3006 gfc_index_zero_node);
3011 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
3012 switch (arrayexpr->ts.type)
3015 tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
3019 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
3020 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
3021 arrayexpr->ts.kind);
3028 /* We start with the most negative possible value for MAXLOC, and the most
3029 positive possible value for MINLOC. The most negative possible value is
3030 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3031 possible value is HUGE in both cases. */
3033 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
3034 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
3035 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
3036 build_int_cst (type, 1));
3038 gfc_add_modify (&se->pre, limit, tmp);
3040 /* Initialize the scalarizer. */
3041 gfc_init_loopinfo (&loop);
3042 gfc_add_ss_to_loop (&loop, arrayss);
3044 gfc_add_ss_to_loop (&loop, maskss);
3046 /* Initialize the loop. */
3047 gfc_conv_ss_startstride (&loop);
3048 gfc_conv_loop_setup (&loop, &expr->where);
3050 gcc_assert (loop.dimen == 1);
3051 if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
3052 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3053 loop.from[0], loop.to[0]);
3057 /* Initialize the position to zero, following Fortran 2003. We are free
3058 to do this because Fortran 95 allows the result of an entirely false
3059 mask to be processor dependent. If we know at compile time the array
3060 is non-empty and no MASK is used, we can initialize to 1 to simplify
3062 if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
3063 gfc_add_modify (&loop.pre, pos,
3064 fold_build3_loc (input_location, COND_EXPR,
3065 gfc_array_index_type,
3066 nonempty, gfc_index_one_node,
3067 gfc_index_zero_node));
3070 gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
3071 lab1 = gfc_build_label_decl (NULL_TREE);
3072 TREE_USED (lab1) = 1;
3073 lab2 = gfc_build_label_decl (NULL_TREE);
3074 TREE_USED (lab2) = 1;
3077 gfc_mark_ss_chain_used (arrayss, 1);
3079 gfc_mark_ss_chain_used (maskss, 1);
3080 /* Generate the loop body. */
3081 gfc_start_scalarized_body (&loop, &body);
3083 /* If we have a mask, only check this element if the mask is set. */
3086 gfc_init_se (&maskse, NULL);
3087 gfc_copy_loopinfo_to_se (&maskse, &loop);
3089 gfc_conv_expr_val (&maskse, maskexpr);
3090 gfc_add_block_to_block (&body, &maskse.pre);
3092 gfc_start_block (&block);
3095 gfc_init_block (&block);
3097 /* Compare with the current limit. */
3098 gfc_init_se (&arrayse, NULL);
3099 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3100 arrayse.ss = arrayss;
3101 gfc_conv_expr_val (&arrayse, arrayexpr);
3102 gfc_add_block_to_block (&block, &arrayse.pre);
3104 /* We do the following if this is a more extreme value. */
3105 gfc_start_block (&ifblock);
3107 /* Assign the value to the limit... */
3108 gfc_add_modify (&ifblock, limit, arrayse.expr);
3110 /* Remember where we are. An offset must be added to the loop
3111 counter to obtain the required position. */
3113 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3114 gfc_index_one_node, loop.from[0]);
3116 tmp = gfc_index_one_node;
3118 gfc_add_modify (&block, offset, tmp);
3120 if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
3122 stmtblock_t ifblock2;
3125 gfc_start_block (&ifblock2);
3126 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3127 loop.loopvar[0], offset);
3128 gfc_add_modify (&ifblock2, pos, tmp);
3129 ifbody2 = gfc_finish_block (&ifblock2);
3130 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pos,
3131 gfc_index_zero_node);
3132 tmp = build3_v (COND_EXPR, cond, ifbody2,
3133 build_empty_stmt (input_location));
3134 gfc_add_expr_to_block (&block, tmp);
3137 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3138 loop.loopvar[0], offset);
3139 gfc_add_modify (&ifblock, pos, tmp);
3142 gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
3144 ifbody = gfc_finish_block (&ifblock);
3146 if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
3149 cond = fold_build2_loc (input_location,
3150 op == GT_EXPR ? GE_EXPR : LE_EXPR,
3151 boolean_type_node, arrayse.expr, limit);
3153 cond = fold_build2_loc (input_location, op, boolean_type_node,
3154 arrayse.expr, limit);
3156 ifbody = build3_v (COND_EXPR, cond, ifbody,
3157 build_empty_stmt (input_location));
3159 gfc_add_expr_to_block (&block, ifbody);
3163 /* We enclose the above in if (mask) {...}. */
3164 tmp = gfc_finish_block (&block);
3166 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3167 build_empty_stmt (input_location));
3170 tmp = gfc_finish_block (&block);
3171 gfc_add_expr_to_block (&body, tmp);
3175 gfc_trans_scalarized_loop_end (&loop, 0, &body);
3177 if (HONOR_NANS (DECL_MODE (limit)))
3179 if (nonempty != NULL)
3181 ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
3182 tmp = build3_v (COND_EXPR, nonempty, ifbody,
3183 build_empty_stmt (input_location));
3184 gfc_add_expr_to_block (&loop.code[0], tmp);
3188 gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
3189 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
3190 gfc_start_block (&body);
3192 /* If we have a mask, only check this element if the mask is set. */
3195 gfc_init_se (&maskse, NULL);
3196 gfc_copy_loopinfo_to_se (&maskse, &loop);
3198 gfc_conv_expr_val (&maskse, maskexpr);
3199 gfc_add_block_to_block (&body, &maskse.pre);
3201 gfc_start_block (&block);
3204 gfc_init_block (&block);
3206 /* Compare with the current limit. */
3207 gfc_init_se (&arrayse, NULL);
3208 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3209 arrayse.ss = arrayss;
3210 gfc_conv_expr_val (&arrayse, arrayexpr);
3211 gfc_add_block_to_block (&block, &arrayse.pre);
3213 /* We do the following if this is a more extreme value. */
3214 gfc_start_block (&ifblock);
3216 /* Assign the value to the limit... */
3217 gfc_add_modify (&ifblock, limit, arrayse.expr);
3219 /* Remember where we are. An offset must be added to the loop
3220 counter to obtain the required position. */
3222 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3223 gfc_index_one_node, loop.from[0]);
3225 tmp = gfc_index_one_node;
3227 gfc_add_modify (&block, offset, tmp);
3229 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3230 loop.loopvar[0], offset);
3231 gfc_add_modify (&ifblock, pos, tmp);
3233 ifbody = gfc_finish_block (&ifblock);
3235 cond = fold_build2_loc (input_location, op, boolean_type_node,
3236 arrayse.expr, limit);
3238 tmp = build3_v (COND_EXPR, cond, ifbody,
3239 build_empty_stmt (input_location));
3240 gfc_add_expr_to_block (&block, tmp);
3244 /* We enclose the above in if (mask) {...}. */
3245 tmp = gfc_finish_block (&block);
3247 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3248 build_empty_stmt (input_location));
3251 tmp = gfc_finish_block (&block);
3252 gfc_add_expr_to_block (&body, tmp);
3253 /* Avoid initializing loopvar[0] again, it should be left where
3254 it finished by the first loop. */
3255 loop.from[0] = loop.loopvar[0];
3258 gfc_trans_scalarizing_loops (&loop, &body);
3261 gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
3263 /* For a scalar mask, enclose the loop in an if statement. */
3264 if (maskexpr && maskss == NULL)
3266 gfc_init_se (&maskse, NULL);
3267 gfc_conv_expr_val (&maskse, maskexpr);
3268 gfc_init_block (&block);
3269 gfc_add_block_to_block (&block, &loop.pre);
3270 gfc_add_block_to_block (&block, &loop.post);
3271 tmp = gfc_finish_block (&block);
3273 /* For the else part of the scalar mask, just initialize
3274 the pos variable the same way as above. */
3276 gfc_init_block (&elseblock);
3277 gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
3278 elsetmp = gfc_finish_block (&elseblock);
3280 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
3281 gfc_add_expr_to_block (&block, tmp);
3282 gfc_add_block_to_block (&se->pre, &block);
3286 gfc_add_block_to_block (&se->pre, &loop.pre);
3287 gfc_add_block_to_block (&se->pre, &loop.post);
3289 gfc_cleanup_loop (&loop);
3291 se->expr = convert (type, pos);
3294 /* Emit code for minval or maxval intrinsic. There are many different cases
3295 we need to handle. For performance reasons we sometimes create two
3296 loops instead of one, where the second one is much simpler.
3297 Examples for minval intrinsic:
3298 1) Result is an array, a call is generated
3299 2) Array mask is used and NaNs need to be supported, rank 1:
3304 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
3307 limit = nonempty ? NaN : huge (limit);
3309 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
3310 3) NaNs need to be supported, but it is known at compile time or cheaply
3311 at runtime whether array is nonempty or not, rank 1:
3314 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
3315 limit = (from <= to) ? NaN : huge (limit);
3317 while (S <= to) { limit = min (a[S], limit); S++; }
3318 4) Array mask is used and NaNs need to be supported, rank > 1:
3327 if (fast) limit = min (a[S1][S2], limit);
3330 if (a[S1][S2] <= limit) {
3341 limit = nonempty ? NaN : huge (limit);
3342 5) NaNs need to be supported, but it is known at compile time or cheaply
3343 at runtime whether array is nonempty or not, rank > 1:
3350 if (fast) limit = min (a[S1][S2], limit);
3352 if (a[S1][S2] <= limit) {
3362 limit = (nonempty_array) ? NaN : huge (limit);
3363 6) NaNs aren't supported, but infinities are. Array mask is used:
3368 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
3371 limit = nonempty ? limit : huge (limit);
3372 7) Same without array mask:
3375 while (S <= to) { limit = min (a[S], limit); S++; }
3376 limit = (from <= to) ? limit : huge (limit);
3377 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
3378 limit = huge (limit);
3380 while (S <= to) { limit = min (a[S], limit); S++); }
3382 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
3383 with array mask instead).
3384 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
3385 setting limit = huge (limit); in the else branch. */
3388 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
3398 tree huge_cst = NULL, nan_cst = NULL;
3400 stmtblock_t block, block2;
3402 gfc_actual_arglist *actual;
3407 gfc_expr *arrayexpr;
3413 gfc_conv_intrinsic_funcall (se, expr);
3417 type = gfc_typenode_for_spec (&expr->ts);
3418 /* Initialize the result. */
3419 limit = gfc_create_var (type, "limit");
3420 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
3421 switch (expr->ts.type)
3424 huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
3426 if (HONOR_INFINITIES (DECL_MODE (limit)))
3428 REAL_VALUE_TYPE real;
3430 tmp = build_real (type, real);
3434 if (HONOR_NANS (DECL_MODE (limit)))
3436 REAL_VALUE_TYPE real;
3437 real_nan (&real, "", 1, DECL_MODE (limit));
3438 nan_cst = build_real (type, real);
3443 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
3450 /* We start with the most negative possible value for MAXVAL, and the most
3451 positive possible value for MINVAL. The most negative possible value is
3452 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3453 possible value is HUGE in both cases. */
3456 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
3458 huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
3459 TREE_TYPE (huge_cst), huge_cst);
3462 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
3463 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
3464 tmp, build_int_cst (type, 1));
3466 gfc_add_modify (&se->pre, limit, tmp);
3468 /* Walk the arguments. */
3469 actual = expr->value.function.actual;
3470 arrayexpr = actual->expr;
3471 arrayss = gfc_walk_expr (arrayexpr);
3472 gcc_assert (arrayss != gfc_ss_terminator);
3474 actual = actual->next->next;
3475 gcc_assert (actual);
3476 maskexpr = actual->expr;
3478 if (maskexpr && maskexpr->rank != 0)
3480 maskss = gfc_walk_expr (maskexpr);
3481 gcc_assert (maskss != gfc_ss_terminator);
3486 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
3488 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
3490 nonempty = fold_build2_loc (input_location, GT_EXPR,
3491 boolean_type_node, nonempty,
3492 gfc_index_zero_node);
3497 /* Initialize the scalarizer. */
3498 gfc_init_loopinfo (&loop);
3499 gfc_add_ss_to_loop (&loop, arrayss);
3501 gfc_add_ss_to_loop (&loop, maskss);
3503 /* Initialize the loop. */
3504 gfc_conv_ss_startstride (&loop);
3505 gfc_conv_loop_setup (&loop, &expr->where);
3507 if (nonempty == NULL && maskss == NULL
3508 && loop.dimen == 1 && loop.from[0] && loop.to[0])
3509 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3510 loop.from[0], loop.to[0]);
3511 nonempty_var = NULL;
3512 if (nonempty == NULL
3513 && (HONOR_INFINITIES (DECL_MODE (limit))
3514 || HONOR_NANS (DECL_MODE (limit))))
3516 nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
3517 gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
3518 nonempty = nonempty_var;
3522 if (HONOR_NANS (DECL_MODE (limit)))
3524 if (loop.dimen == 1)
3526 lab = gfc_build_label_decl (NULL_TREE);
3527 TREE_USED (lab) = 1;
3531 fast = gfc_create_var (boolean_type_node, "fast");
3532 gfc_add_modify (&se->pre, fast, boolean_false_node);
3536 gfc_mark_ss_chain_used (arrayss, 1);
3538 gfc_mark_ss_chain_used (maskss, 1);
3539 /* Generate the loop body. */
3540 gfc_start_scalarized_body (&loop, &body);
3542 /* If we have a mask, only add this element if the mask is set. */
3545 gfc_init_se (&maskse, NULL);
3546 gfc_copy_loopinfo_to_se (&maskse, &loop);
3548 gfc_conv_expr_val (&maskse, maskexpr);
3549 gfc_add_block_to_block (&body, &maskse.pre);
3551 gfc_start_block (&block);
3554 gfc_init_block (&block);
3556 /* Compare with the current limit. */
3557 gfc_init_se (&arrayse, NULL);
3558 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3559 arrayse.ss = arrayss;
3560 gfc_conv_expr_val (&arrayse, arrayexpr);
3561 gfc_add_block_to_block (&block, &arrayse.pre);
3563 gfc_init_block (&block2);
3566 gfc_add_modify (&block2, nonempty_var, boolean_true_node);
3568 if (HONOR_NANS (DECL_MODE (limit)))
3570 tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
3571 boolean_type_node, arrayse.expr, limit);
3573 ifbody = build1_v (GOTO_EXPR, lab);
3576 stmtblock_t ifblock;
3578 gfc_init_block (&ifblock);
3579 gfc_add_modify (&ifblock, limit, arrayse.expr);
3580 gfc_add_modify (&ifblock, fast, boolean_true_node);
3581 ifbody = gfc_finish_block (&ifblock);
3583 tmp = build3_v (COND_EXPR, tmp, ifbody,
3584 build_empty_stmt (input_location));
3585 gfc_add_expr_to_block (&block2, tmp);
3589 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3591 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3593 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3594 arrayse.expr, limit);
3595 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3596 tmp = build3_v (COND_EXPR, tmp, ifbody,
3597 build_empty_stmt (input_location));
3598 gfc_add_expr_to_block (&block2, tmp);
3602 tmp = fold_build2_loc (input_location,
3603 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3604 type, arrayse.expr, limit);
3605 gfc_add_modify (&block2, limit, tmp);
3611 tree elsebody = gfc_finish_block (&block2);
3613 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3615 if (HONOR_NANS (DECL_MODE (limit))
3616 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3618 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3619 arrayse.expr, limit);
3620 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3621 ifbody = build3_v (COND_EXPR, tmp, ifbody,
3622 build_empty_stmt (input_location));
3626 tmp = fold_build2_loc (input_location,
3627 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3628 type, arrayse.expr, limit);
3629 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
3631 tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
3632 gfc_add_expr_to_block (&block, tmp);
3635 gfc_add_block_to_block (&block, &block2);
3637 gfc_add_block_to_block (&block, &arrayse.post);
3639 tmp = gfc_finish_block (&block);
3641 /* We enclose the above in if (mask) {...}. */
3642 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3643 build_empty_stmt (input_location));
3644 gfc_add_expr_to_block (&body, tmp);
3648 gfc_trans_scalarized_loop_end (&loop, 0, &body);
3650 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
3652 gfc_add_modify (&loop.code[0], limit, tmp);
3653 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
3655 gfc_start_block (&body);
3657 /* If we have a mask, only add this element if the mask is set. */
3660 gfc_init_se (&maskse, NULL);
3661 gfc_copy_loopinfo_to_se (&maskse, &loop);
3663 gfc_conv_expr_val (&maskse, maskexpr);
3664 gfc_add_block_to_block (&body, &maskse.pre);
3666 gfc_start_block (&block);
3669 gfc_init_block (&block);
3671 /* Compare with the current limit. */
3672 gfc_init_se (&arrayse, NULL);
3673 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3674 arrayse.ss = arrayss;
3675 gfc_conv_expr_val (&arrayse, arrayexpr);
3676 gfc_add_block_to_block (&block, &arrayse.pre);
3678 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3680 if (HONOR_NANS (DECL_MODE (limit))
3681 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3683 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3684 arrayse.expr, limit);
3685 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3686 tmp = build3_v (COND_EXPR, tmp, ifbody,
3687 build_empty_stmt (input_location));
3688 gfc_add_expr_to_block (&block, tmp);
3692 tmp = fold_build2_loc (input_location,
3693 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3694 type, arrayse.expr, limit);
3695 gfc_add_modify (&block, limit, tmp);
3698 gfc_add_block_to_block (&block, &arrayse.post);
3700 tmp = gfc_finish_block (&block);
3702 /* We enclose the above in if (mask) {...}. */
3703 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3704 build_empty_stmt (input_location));
3705 gfc_add_expr_to_block (&body, tmp);
3706 /* Avoid initializing loopvar[0] again, it should be left where
3707 it finished by the first loop. */
3708 loop.from[0] = loop.loopvar[0];
3710 gfc_trans_scalarizing_loops (&loop, &body);
3714 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
3716 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
3717 tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
3719 gfc_add_expr_to_block (&loop.pre, tmp);
3721 else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
3723 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
3725 gfc_add_modify (&loop.pre, limit, tmp);
3728 /* For a scalar mask, enclose the loop in an if statement. */
3729 if (maskexpr && maskss == NULL)
3733 gfc_init_se (&maskse, NULL);
3734 gfc_conv_expr_val (&maskse, maskexpr);
3735 gfc_init_block (&block);
3736 gfc_add_block_to_block (&block, &loop.pre);
3737 gfc_add_block_to_block (&block, &loop.post);
3738 tmp = gfc_finish_block (&block);
3740 if (HONOR_INFINITIES (DECL_MODE (limit)))
3741 else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
3743 else_stmt = build_empty_stmt (input_location);
3744 tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
3745 gfc_add_expr_to_block (&block, tmp);
3746 gfc_add_block_to_block (&se->pre, &block);
3750 gfc_add_block_to_block (&se->pre, &loop.pre);
3751 gfc_add_block_to_block (&se->pre, &loop.post);
3754 gfc_cleanup_loop (&loop);
3759 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3761 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
3767 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3768 type = TREE_TYPE (args[0]);
3770 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3771 build_int_cst (type, 1), args[1]);
3772 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
3773 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
3774 build_int_cst (type, 0));
3775 type = gfc_typenode_for_spec (&expr->ts);
3776 se->expr = convert (type, tmp);
3780 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
3782 gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
3786 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3788 /* Convert both arguments to the unsigned type of the same size. */
3789 args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
3790 args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
3792 /* If they have unequal type size, convert to the larger one. */
3793 if (TYPE_PRECISION (TREE_TYPE (args[0]))
3794 > TYPE_PRECISION (TREE_TYPE (args[1])))
3795 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
3796 else if (TYPE_PRECISION (TREE_TYPE (args[1]))
3797 > TYPE_PRECISION (TREE_TYPE (args[0])))
3798 args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
3800 /* Now, we compare them. */
3801 se->expr = fold_build2_loc (input_location, op, boolean_type_node,
3806 /* Generate code to perform the specified operation. */
3808 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
3812 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3813 se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
3819 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
3823 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3824 se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
3825 TREE_TYPE (arg), arg);
3828 /* Set or clear a single bit. */
3830 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
3837 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3838 type = TREE_TYPE (args[0]);
3840 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3841 build_int_cst (type, 1), args[1]);
3847 tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
3849 se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
3852 /* Extract a sequence of bits.
3853 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3855 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
3862 gfc_conv_intrinsic_function_args (se, expr, args, 3);
3863 type = TREE_TYPE (args[0]);
3865 mask = build_int_cst (type, -1);
3866 mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
3867 mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
3869 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
3871 se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
3875 gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
3878 tree args[2], type, num_bits, cond;
3880 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3882 args[0] = gfc_evaluate_now (args[0], &se->pre);
3883 args[1] = gfc_evaluate_now (args[1], &se->pre);
3884 type = TREE_TYPE (args[0]);
3887 args[0] = fold_convert (unsigned_type_for (type), args[0]);
3889 gcc_assert (right_shift);
3891 se->expr = fold_build2_loc (input_location,
3892 right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
3893 TREE_TYPE (args[0]), args[0], args[1]);
3896 se->expr = fold_convert (type, se->expr);
3898 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3899 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3901 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
3902 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3905 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
3906 build_int_cst (type, 0), se->expr);
3909 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
3911 : ((shift >= 0) ? i << shift : i >> -shift)
3912 where all shifts are logical shifts. */
3914 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
3926 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3928 args[0] = gfc_evaluate_now (args[0], &se->pre);
3929 args[1] = gfc_evaluate_now (args[1], &se->pre);
3931 type = TREE_TYPE (args[0]);
3932 utype = unsigned_type_for (type);
3934 width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
3937 /* Left shift if positive. */
3938 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
3940 /* Right shift if negative.
3941 We convert to an unsigned type because we want a logical shift.
3942 The standard doesn't define the case of shifting negative
3943 numbers, and we try to be compatible with other compilers, most
3944 notably g77, here. */
3945 rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
3946 utype, convert (utype, args[0]), width));
3948 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, args[1],
3949 build_int_cst (TREE_TYPE (args[1]), 0));
3950 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
3952 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3953 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3955 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
3956 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, width,
3958 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
3959 build_int_cst (type, 0), tmp);
3963 /* Circular shift. AKA rotate or barrel shift. */
3966 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
3974 unsigned int num_args;
3976 num_args = gfc_intrinsic_argument_list_length (expr);
3977 args = XALLOCAVEC (tree, num_args);
3979 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3983 /* Use a library function for the 3 parameter version. */
3984 tree int4type = gfc_get_int_type (4);
3986 type = TREE_TYPE (args[0]);
3987 /* We convert the first argument to at least 4 bytes, and
3988 convert back afterwards. This removes the need for library
3989 functions for all argument sizes, and function will be
3990 aligned to at least 32 bits, so there's no loss. */
3991 if (expr->ts.kind < 4)
3992 args[0] = convert (int4type, args[0]);
3994 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
3995 need loads of library functions. They cannot have values >
3996 BIT_SIZE (I) so the conversion is safe. */
3997 args[1] = convert (int4type, args[1]);
3998 args[2] = convert (int4type, args[2]);
4000 switch (expr->ts.kind)
4005 tmp = gfor_fndecl_math_ishftc4;
4008 tmp = gfor_fndecl_math_ishftc8;
4011 tmp = gfor_fndecl_math_ishftc16;
4016 se->expr = build_call_expr_loc (input_location,
4017 tmp, 3, args[0], args[1], args[2]);
4018 /* Convert the result back to the original type, if we extended
4019 the first argument's width above. */
4020 if (expr->ts.kind < 4)
4021 se->expr = convert (type, se->expr);
4025 type = TREE_TYPE (args[0]);
4027 /* Evaluate arguments only once. */
4028 args[0] = gfc_evaluate_now (args[0], &se->pre);
4029 args[1] = gfc_evaluate_now (args[1], &se->pre);
4031 /* Rotate left if positive. */
4032 lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
4034 /* Rotate right if negative. */
4035 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
4037 rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
4039 zero = build_int_cst (TREE_TYPE (args[1]), 0);
4040 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, args[1],
4042 rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
4044 /* Do nothing if shift == 0. */
4045 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, args[1],
4047 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
4052 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4053 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4055 The conditional expression is necessary because the result of LEADZ(0)
4056 is defined, but the result of __builtin_clz(0) is undefined for most
4059 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4060 difference in bit size between the argument of LEADZ and the C int. */
4063 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
4075 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4076 argsize = TYPE_PRECISION (TREE_TYPE (arg));
4078 /* Which variant of __builtin_clz* should we call? */
4079 if (argsize <= INT_TYPE_SIZE)
4081 arg_type = unsigned_type_node;
4082 func = built_in_decls[BUILT_IN_CLZ];
4084 else if (argsize <= LONG_TYPE_SIZE)
4086 arg_type = long_unsigned_type_node;
4087 func = built_in_decls[BUILT_IN_CLZL];
4089 else if (argsize <= LONG_LONG_TYPE_SIZE)
4091 arg_type = long_long_unsigned_type_node;
4092 func = built_in_decls[BUILT_IN_CLZLL];
4096 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
4097 arg_type = gfc_build_uint_type (argsize);
4101 /* Convert the actual argument twice: first, to the unsigned type of the
4102 same size; then, to the proper argument type for the built-in
4103 function. But the return type is of the default INTEGER kind. */
4104 arg = fold_convert (gfc_build_uint_type (argsize), arg);
4105 arg = fold_convert (arg_type, arg);
4106 arg = gfc_evaluate_now (arg, &se->pre);
4107 result_type = gfc_get_int_type (gfc_default_integer_kind);
4109 /* Compute LEADZ for the case i .ne. 0. */
4112 s = TYPE_PRECISION (arg_type) - argsize;
4113 tmp = fold_convert (result_type,
4114 build_call_expr_loc (input_location, func,
4116 leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
4117 tmp, build_int_cst (result_type, s));
4121 /* We end up here if the argument type is larger than 'long long'.
4122 We generate this code:
4124 if (x & (ULL_MAX << ULL_SIZE) != 0)
4125 return clzll ((unsigned long long) (x >> ULLSIZE));
4127 return ULL_SIZE + clzll ((unsigned long long) x);
4128 where ULL_MAX is the largest value that a ULL_MAX can hold
4129 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4130 is the bit-size of the long long type (64 in this example). */
4131 tree ullsize, ullmax, tmp1, tmp2;
4133 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
4134 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
4135 long_long_unsigned_type_node,
4136 build_int_cst (long_long_unsigned_type_node,
4139 cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
4140 fold_convert (arg_type, ullmax), ullsize);
4141 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
4143 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4144 cond, build_int_cst (arg_type, 0));
4146 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
4148 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
4149 tmp1 = fold_convert (result_type,
4150 build_call_expr_loc (input_location,
4151 built_in_decls[BUILT_IN_CLZLL],
4154 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
4155 tmp2 = fold_convert (result_type,
4156 build_call_expr_loc (input_location,
4157 built_in_decls[BUILT_IN_CLZLL],
4159 tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
4162 leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
4166 /* Build BIT_SIZE. */
4167 bit_size = build_int_cst (result_type, argsize);
4169 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4170 arg, build_int_cst (arg_type, 0));
4171 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
4176 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4178 The conditional expression is necessary because the result of TRAILZ(0)
4179 is defined, but the result of __builtin_ctz(0) is undefined for most
4183 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
4194 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4195 argsize = TYPE_PRECISION (TREE_TYPE (arg));
4197 /* Which variant of __builtin_ctz* should we call? */
4198 if (argsize <= INT_TYPE_SIZE)
4200 arg_type = unsigned_type_node;
4201 func = built_in_decls[BUILT_IN_CTZ];
4203 else if (argsize <= LONG_TYPE_SIZE)
4205 arg_type = long_unsigned_type_node;
4206 func = built_in_decls[BUILT_IN_CTZL];
4208 else if (argsize <= LONG_LONG_TYPE_SIZE)
4210 arg_type = long_long_unsigned_type_node;
4211 func = built_in_decls[BUILT_IN_CTZLL];
4215 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
4216 arg_type = gfc_build_uint_type (argsize);
4220 /* Convert the actual argument twice: first, to the unsigned type of the
4221 same size; then, to the proper argument type for the built-in
4222 function. But the return type is of the default INTEGER kind. */
4223 arg = fold_convert (gfc_build_uint_type (argsize), arg);
4224 arg = fold_convert (arg_type, arg);
4225 arg = gfc_evaluate_now (arg, &se->pre);
4226 result_type = gfc_get_int_type (gfc_default_integer_kind);
4228 /* Compute TRAILZ for the case i .ne. 0. */
4230 trailz = fold_convert (result_type, build_call_expr_loc (input_location,
4234 /* We end up here if the argument type is larger than 'long long'.
4235 We generate this code:
4237 if ((x & ULL_MAX) == 0)
4238 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
4240 return ctzll ((unsigned long long) x);
4242 where ULL_MAX is the largest value that a ULL_MAX can hold
4243 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4244 is the bit-size of the long long type (64 in this example). */
4245 tree ullsize, ullmax, tmp1, tmp2;
4247 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
4248 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
4249 long_long_unsigned_type_node,
4250 build_int_cst (long_long_unsigned_type_node, 0));
4252 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
4253 fold_convert (arg_type, ullmax));
4254 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, cond,
4255 build_int_cst (arg_type, 0));
4257 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
4259 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
4260 tmp1 = fold_convert (result_type,
4261 build_call_expr_loc (input_location,
4262 built_in_decls[BUILT_IN_CTZLL],
4264 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
4267 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
4268 tmp2 = fold_convert (result_type,
4269 build_call_expr_loc (input_location,
4270 built_in_decls[BUILT_IN_CTZLL],
4273 trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
4277 /* Build BIT_SIZE. */
4278 bit_size = build_int_cst (result_type, argsize);
4280 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4281 arg, build_int_cst (arg_type, 0));
4282 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
4286 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
4287 for types larger than "long long", we call the long long built-in for
4288 the lower and higher bits and combine the result. */
4291 gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
4299 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4300 argsize = TYPE_PRECISION (TREE_TYPE (arg));
4301 result_type = gfc_get_int_type (gfc_default_integer_kind);
4303 /* Which variant of the builtin should we call? */
4304 if (argsize <= INT_TYPE_SIZE)
4306 arg_type = unsigned_type_node;
4307 func = built_in_decls[parity ? BUILT_IN_PARITY : BUILT_IN_POPCOUNT];
4309 else if (argsize <= LONG_TYPE_SIZE)
4311 arg_type = long_unsigned_type_node;
4312 func = built_in_decls[parity ? BUILT_IN_PARITYL : BUILT_IN_POPCOUNTL];
4314 else if (argsize <= LONG_LONG_TYPE_SIZE)
4316 arg_type = long_long_unsigned_type_node;
4317 func = built_in_decls[parity ? BUILT_IN_PARITYLL : BUILT_IN_POPCOUNTLL];
4321 /* Our argument type is larger than 'long long', which mean none
4322 of the POPCOUNT builtins covers it. We thus call the 'long long'
4323 variant multiple times, and add the results. */
4324 tree utype, arg2, call1, call2;
4326 /* For now, we only cover the case where argsize is twice as large
4328 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
4330 func = built_in_decls[parity ? BUILT_IN_PARITYLL : BUILT_IN_POPCOUNTLL];
4332 /* Convert it to an integer, and store into a variable. */
4333 utype = gfc_build_uint_type (argsize);
4334 arg = fold_convert (utype, arg);
4335 arg = gfc_evaluate_now (arg, &se->pre);
4337 /* Call the builtin twice. */
4338 call1 = build_call_expr_loc (input_location, func, 1,
4339 fold_convert (long_long_unsigned_type_node,
4342 arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
4343 build_int_cst (utype, LONG_LONG_TYPE_SIZE));
4344 call2 = build_call_expr_loc (input_location, func, 1,
4345 fold_convert (long_long_unsigned_type_node,
4348 /* Combine the results. */
4350 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type,
4353 se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type,
4359 /* Convert the actual argument twice: first, to the unsigned type of the
4360 same size; then, to the proper argument type for the built-in
4362 arg = fold_convert (gfc_build_uint_type (argsize), arg);
4363 arg = fold_convert (arg_type, arg);
4365 se->expr = fold_convert (result_type,
4366 build_call_expr_loc (input_location, func, 1, arg));
4370 /* Process an intrinsic with unspecified argument-types that has an optional
4371 argument (which could be of type character), e.g. EOSHIFT. For those, we
4372 need to append the string length of the optional argument if it is not
4373 present and the type is really character.
4374 primary specifies the position (starting at 1) of the non-optional argument
4375 specifying the type and optional gives the position of the optional
4376 argument in the arglist. */
4379 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
4380 unsigned primary, unsigned optional)
4382 gfc_actual_arglist* prim_arg;
4383 gfc_actual_arglist* opt_arg;
4385 gfc_actual_arglist* arg;
4387 VEC(tree,gc) *append_args;
4389 /* Find the two arguments given as position. */
4393 for (arg = expr->value.function.actual; arg; arg = arg->next)
4397 if (cur_pos == primary)
4399 if (cur_pos == optional)
4402 if (cur_pos >= primary && cur_pos >= optional)
4405 gcc_assert (prim_arg);
4406 gcc_assert (prim_arg->expr);
4407 gcc_assert (opt_arg);
4409 /* If we do have type CHARACTER and the optional argument is really absent,
4410 append a dummy 0 as string length. */
4412 if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
4416 dummy = build_int_cst (gfc_charlen_type_node, 0);
4417 append_args = VEC_alloc (tree, gc, 1);
4418 VEC_quick_push (tree, append_args, dummy);
4421 /* Build the call itself. */
4422 sym = gfc_get_symbol_for_expr (expr);
4423 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4429 /* The length of a character string. */
4431 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
4441 gcc_assert (!se->ss);
4443 arg = expr->value.function.actual->expr;
4445 type = gfc_typenode_for_spec (&expr->ts);
4446 switch (arg->expr_type)
4449 len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
4453 /* Obtain the string length from the function used by
4454 trans-array.c(gfc_trans_array_constructor). */
4456 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
4460 if (arg->ref == NULL
4461 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
4463 /* This doesn't catch all cases.
4464 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
4465 and the surrounding thread. */
4466 sym = arg->symtree->n.sym;
4467 decl = gfc_get_symbol_decl (sym);
4468 if (decl == current_function_decl && sym->attr.function
4469 && (sym->result == sym))
4470 decl = gfc_get_fake_result_decl (sym, 0);
4472 len = sym->ts.u.cl->backend_decl;
4477 /* Otherwise fall through. */
4480 /* Anybody stupid enough to do this deserves inefficient code. */
4481 ss = gfc_walk_expr (arg);
4482 gfc_init_se (&argse, se);
4483 if (ss == gfc_ss_terminator)
4484 gfc_conv_expr (&argse, arg);
4486 gfc_conv_expr_descriptor (&argse, arg, ss);
4487 gfc_add_block_to_block (&se->pre, &argse.pre);
4488 gfc_add_block_to_block (&se->post, &argse.post);
4489 len = argse.string_length;
4492 se->expr = convert (type, len);
4495 /* The length of a character string not including trailing blanks. */
4497 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
4499 int kind = expr->value.function.actual->expr->ts.kind;
4500 tree args[2], type, fndecl;
4502 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4503 type = gfc_typenode_for_spec (&expr->ts);
4506 fndecl = gfor_fndecl_string_len_trim;
4508 fndecl = gfor_fndecl_string_len_trim_char4;
4512 se->expr = build_call_expr_loc (input_location,
4513 fndecl, 2, args[0], args[1]);
4514 se->expr = convert (type, se->expr);
4518 /* Returns the starting position of a substring within a string. */
4521 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
4524 tree logical4_type_node = gfc_get_logical_type (4);
4528 unsigned int num_args;
4530 args = XALLOCAVEC (tree, 5);
4532 /* Get number of arguments; characters count double due to the
4533 string length argument. Kind= is not passed to the library
4534 and thus ignored. */
4535 if (expr->value.function.actual->next->next->expr == NULL)
4540 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
4541 type = gfc_typenode_for_spec (&expr->ts);
4544 args[4] = build_int_cst (logical4_type_node, 0);
4546 args[4] = convert (logical4_type_node, args[4]);
4548 fndecl = build_addr (function, current_function_decl);
4549 se->expr = build_call_array_loc (input_location,
4550 TREE_TYPE (TREE_TYPE (function)), fndecl,
4552 se->expr = convert (type, se->expr);
4556 /* The ascii value for a single character. */
4558 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
4560 tree args[2], type, pchartype;
4562 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4563 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
4564 pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
4565 args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
4566 type = gfc_typenode_for_spec (&expr->ts);
4568 se->expr = build_fold_indirect_ref_loc (input_location,
4570 se->expr = convert (type, se->expr);
4574 /* Intrinsic ISNAN calls __builtin_isnan. */
4577 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
4581 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4582 se->expr = build_call_expr_loc (input_location,
4583 built_in_decls[BUILT_IN_ISNAN], 1, arg);
4584 STRIP_TYPE_NOPS (se->expr);
4585 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4589 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
4590 their argument against a constant integer value. */
4593 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
4597 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4598 se->expr = fold_build2_loc (input_location, EQ_EXPR,
4599 gfc_typenode_for_spec (&expr->ts),
4600 arg, build_int_cst (TREE_TYPE (arg), value));
4605 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
4608 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
4616 unsigned int num_args;
4618 num_args = gfc_intrinsic_argument_list_length (expr);
4619 args = XALLOCAVEC (tree, num_args);
4621 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
4622 if (expr->ts.type != BT_CHARACTER)
4630 /* We do the same as in the non-character case, but the argument
4631 list is different because of the string length arguments. We
4632 also have to set the string length for the result. */
4639 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
4641 se->string_length = len;
4643 type = TREE_TYPE (tsource);
4644 se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
4645 fold_convert (type, fsource));
4649 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
4652 gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
4654 tree args[3], mask, type;
4656 gfc_conv_intrinsic_function_args (se, expr, args, 3);
4657 mask = gfc_evaluate_now (args[2], &se->pre);
4659 type = TREE_TYPE (args[0]);
4660 gcc_assert (TREE_TYPE (args[1]) == type);
4661 gcc_assert (TREE_TYPE (mask) == type);
4663 args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
4664 args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
4665 fold_build1_loc (input_location, BIT_NOT_EXPR,
4667 se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
4672 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
4673 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
4676 gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
4678 tree arg, allones, type, utype, res, cond, bitsize;
4681 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4682 arg = gfc_evaluate_now (arg, &se->pre);
4684 type = gfc_get_int_type (expr->ts.kind);
4685 utype = unsigned_type_for (type);
4687 i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
4688 bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
4690 allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
4691 build_int_cst (utype, 0));
4695 /* Left-justified mask. */
4696 res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
4698 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
4699 fold_convert (utype, res));
4701 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
4702 smaller than type width. */
4703 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
4704 build_int_cst (TREE_TYPE (arg), 0));
4705 res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
4706 build_int_cst (utype, 0), res);
4710 /* Right-justified mask. */
4711 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
4712 fold_convert (utype, arg));
4713 res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
4715 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
4716 strictly smaller than type width. */
4717 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4719 res = fold_build3_loc (input_location, COND_EXPR, utype,
4720 cond, allones, res);
4723 se->expr = fold_convert (type, res);
4727 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
4729 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
4731 tree arg, type, tmp, frexp;
4733 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4735 type = gfc_typenode_for_spec (&expr->ts);
4736 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4737 tmp = gfc_create_var (integer_type_node, NULL);
4738 se->expr = build_call_expr_loc (input_location, frexp, 2,
4739 fold_convert (type, arg),
4740 gfc_build_addr_expr (NULL_TREE, tmp));
4741 se->expr = fold_convert (type, se->expr);
4745 /* NEAREST (s, dir) is translated into
4746 tmp = copysign (HUGE_VAL, dir);
4747 return nextafter (s, tmp);
4750 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
4752 tree args[2], type, tmp, nextafter, copysign, huge_val;
4754 nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
4755 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
4757 type = gfc_typenode_for_spec (&expr->ts);
4758 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4760 huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
4761 tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
4762 fold_convert (type, args[1]));
4763 se->expr = build_call_expr_loc (input_location, nextafter, 2,
4764 fold_convert (type, args[0]), tmp);
4765 se->expr = fold_convert (type, se->expr);
4769 /* SPACING (s) is translated into
4777 e = MAX_EXPR (e, emin);
4778 res = scalbn (1., e);
4782 where prec is the precision of s, gfc_real_kinds[k].digits,
4783 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
4784 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
4787 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
4789 tree arg, type, prec, emin, tiny, res, e;
4790 tree cond, tmp, frexp, scalbn;
4794 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
4795 prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
4796 emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
4797 tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
4799 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4800 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4802 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4803 arg = gfc_evaluate_now (arg, &se->pre);
4805 type = gfc_typenode_for_spec (&expr->ts);
4806 e = gfc_create_var (integer_type_node, NULL);
4807 res = gfc_create_var (type, NULL);
4810 /* Build the block for s /= 0. */
4811 gfc_start_block (&block);
4812 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
4813 gfc_build_addr_expr (NULL_TREE, e));
4814 gfc_add_expr_to_block (&block, tmp);
4816 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
4818 gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
4819 integer_type_node, tmp, emin));
4821 tmp = build_call_expr_loc (input_location, scalbn, 2,
4822 build_real_from_int_cst (type, integer_one_node), e);
4823 gfc_add_modify (&block, res, tmp);
4825 /* Finish by building the IF statement. */
4826 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
4827 build_real_from_int_cst (type, integer_zero_node));
4828 tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
4829 gfc_finish_block (&block));
4831 gfc_add_expr_to_block (&se->pre, tmp);
4836 /* RRSPACING (s) is translated into
4843 x = scalbn (x, precision - e);
4847 where precision is gfc_real_kinds[k].digits. */
4850 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
4852 tree arg, type, e, x, cond, stmt, tmp, frexp, scalbn, fabs;
4856 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
4857 prec = gfc_real_kinds[k].digits;
4859 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4860 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4861 fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
4863 type = gfc_typenode_for_spec (&expr->ts);
4864 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4865 arg = gfc_evaluate_now (arg, &se->pre);
4867 e = gfc_create_var (integer_type_node, NULL);
4868 x = gfc_create_var (type, NULL);
4869 gfc_add_modify (&se->pre, x,
4870 build_call_expr_loc (input_location, fabs, 1, arg));
4873 gfc_start_block (&block);
4874 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
4875 gfc_build_addr_expr (NULL_TREE, e));
4876 gfc_add_expr_to_block (&block, tmp);
4878 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4879 build_int_cst (integer_type_node, prec), e);
4880 tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
4881 gfc_add_modify (&block, x, tmp);
4882 stmt = gfc_finish_block (&block);
4884 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, x,
4885 build_real_from_int_cst (type, integer_zero_node));
4886 tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
4887 gfc_add_expr_to_block (&se->pre, tmp);
4889 se->expr = fold_convert (type, x);
4893 /* SCALE (s, i) is translated into scalbn (s, i). */
4895 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
4897 tree args[2], type, scalbn;
4899 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4901 type = gfc_typenode_for_spec (&expr->ts);
4902 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4903 se->expr = build_call_expr_loc (input_location, scalbn, 2,
4904 fold_convert (type, args[0]),
4905 fold_convert (integer_type_node, args[1]));
4906 se->expr = fold_convert (type, se->expr);
4910 /* SET_EXPONENT (s, i) is translated into
4911 scalbn (frexp (s, &dummy_int), i). */
4913 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
4915 tree args[2], type, tmp, frexp, scalbn;
4917 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4918 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4920 type = gfc_typenode_for_spec (&expr->ts);
4921 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4923 tmp = gfc_create_var (integer_type_node, NULL);
4924 tmp = build_call_expr_loc (input_location, frexp, 2,
4925 fold_convert (type, args[0]),
4926 gfc_build_addr_expr (NULL_TREE, tmp));
4927 se->expr = build_call_expr_loc (input_location, scalbn, 2, tmp,
4928 fold_convert (integer_type_node, args[1]));
4929 se->expr = fold_convert (type, se->expr);
4934 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
4936 gfc_actual_arglist *actual;
4944 gfc_init_se (&argse, NULL);
4945 actual = expr->value.function.actual;
4947 ss = gfc_walk_expr (actual->expr);
4948 gcc_assert (ss != gfc_ss_terminator);
4949 argse.want_pointer = 1;
4950 argse.data_not_needed = 1;
4951 gfc_conv_expr_descriptor (&argse, actual->expr, ss);
4952 gfc_add_block_to_block (&se->pre, &argse.pre);
4953 gfc_add_block_to_block (&se->post, &argse.post);
4954 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
4956 /* Build the call to size0. */
4957 fncall0 = build_call_expr_loc (input_location,
4958 gfor_fndecl_size0, 1, arg1);
4960 actual = actual->next;
4964 gfc_init_se (&argse, NULL);
4965 gfc_conv_expr_type (&argse, actual->expr,
4966 gfc_array_index_type);
4967 gfc_add_block_to_block (&se->pre, &argse.pre);
4969 /* Unusually, for an intrinsic, size does not exclude
4970 an optional arg2, so we must test for it. */
4971 if (actual->expr->expr_type == EXPR_VARIABLE
4972 && actual->expr->symtree->n.sym->attr.dummy
4973 && actual->expr->symtree->n.sym->attr.optional)
4976 /* Build the call to size1. */
4977 fncall1 = build_call_expr_loc (input_location,
4978 gfor_fndecl_size1, 2,
4981 gfc_init_se (&argse, NULL);
4982 argse.want_pointer = 1;
4983 argse.data_not_needed = 1;
4984 gfc_conv_expr (&argse, actual->expr);
4985 gfc_add_block_to_block (&se->pre, &argse.pre);
4986 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4987 argse.expr, null_pointer_node);
4988 tmp = gfc_evaluate_now (tmp, &se->pre);
4989 se->expr = fold_build3_loc (input_location, COND_EXPR,
4990 pvoid_type_node, tmp, fncall1, fncall0);
4994 se->expr = NULL_TREE;
4995 argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
4996 gfc_array_index_type,
4997 argse.expr, gfc_index_one_node);
5000 else if (expr->value.function.actual->expr->rank == 1)
5002 argse.expr = gfc_index_zero_node;
5003 se->expr = NULL_TREE;
5008 if (se->expr == NULL_TREE)
5010 tree ubound, lbound;
5012 arg1 = build_fold_indirect_ref_loc (input_location,
5014 ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
5015 lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
5016 se->expr = fold_build2_loc (input_location, MINUS_EXPR,
5017 gfc_array_index_type, ubound, lbound);
5018 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
5019 gfc_array_index_type,
5020 se->expr, gfc_index_one_node);
5021 se->expr = fold_build2_loc (input_location, MAX_EXPR,
5022 gfc_array_index_type, se->expr,
5023 gfc_index_zero_node);
5026 type = gfc_typenode_for_spec (&expr->ts);
5027 se->expr = convert (type, se->expr);
5031 /* Helper function to compute the size of a character variable,
5032 excluding the terminating null characters. The result has
5033 gfc_array_index_type type. */
5036 size_of_string_in_bytes (int kind, tree string_length)
5039 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
5041 bytesize = build_int_cst (gfc_array_index_type,
5042 gfc_character_kinds[i].bit_size / 8);
5044 return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5046 fold_convert (gfc_array_index_type, string_length));
5051 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
5063 arg = expr->value.function.actual->expr;
5065 gfc_init_se (&argse, NULL);
5066 ss = gfc_walk_expr (arg);
5068 if (ss == gfc_ss_terminator)
5070 if (arg->ts.type == BT_CLASS)
5071 gfc_add_data_component (arg);
5073 gfc_conv_expr_reference (&argse, arg);
5075 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5078 /* Obtain the source word length. */
5079 if (arg->ts.type == BT_CHARACTER)
5080 se->expr = size_of_string_in_bytes (arg->ts.kind,
5081 argse.string_length);
5083 se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
5087 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
5088 argse.want_pointer = 0;
5089 gfc_conv_expr_descriptor (&argse, arg, ss);
5090 type = gfc_get_element_type (TREE_TYPE (argse.expr));
5092 /* Obtain the argument's word length. */
5093 if (arg->ts.type == BT_CHARACTER)
5094 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
5096 tmp = fold_convert (gfc_array_index_type,
5097 size_in_bytes (type));
5098 gfc_add_modify (&argse.pre, source_bytes, tmp);
5100 /* Obtain the size of the array in bytes. */
5101 for (n = 0; n < arg->rank; n++)
5104 idx = gfc_rank_cst[n];
5105 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
5106 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
5107 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5108 gfc_array_index_type, upper, lower);
5109 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5110 gfc_array_index_type, tmp, gfc_index_one_node);
5111 tmp = fold_build2_loc (input_location, MULT_EXPR,
5112 gfc_array_index_type, tmp, source_bytes);
5113 gfc_add_modify (&argse.pre, source_bytes, tmp);
5115 se->expr = source_bytes;
5118 gfc_add_block_to_block (&se->pre, &argse.pre);
5123 gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
5128 tree type, result_type, tmp;
5130 arg = expr->value.function.actual->expr;
5131 gfc_init_se (&eight, NULL);
5132 gfc_conv_expr (&eight, gfc_get_int_expr (expr->ts.kind, NULL, 8));
5134 gfc_init_se (&argse, NULL);
5135 ss = gfc_walk_expr (arg);
5136 result_type = gfc_get_int_type (expr->ts.kind);
5138 if (ss == gfc_ss_terminator)
5140 if (arg->ts.type == BT_CLASS)
5142 gfc_add_vptr_component (arg);
5143 gfc_add_size_component (arg);
5144 gfc_conv_expr (&argse, arg);
5145 tmp = fold_convert (result_type, argse.expr);
5149 gfc_conv_expr_reference (&argse, arg);
5150 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5155 argse.want_pointer = 0;
5156 gfc_conv_expr_descriptor (&argse, arg, ss);
5157 type = gfc_get_element_type (TREE_TYPE (argse.expr));
5160 /* Obtain the argument's word length. */
5161 if (arg->ts.type == BT_CHARACTER)
5162 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
5164 tmp = fold_convert (result_type, size_in_bytes (type));
5167 se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
5169 gfc_add_block_to_block (&se->pre, &argse.pre);
5173 /* Intrinsic string comparison functions. */
5176 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
5180 gfc_conv_intrinsic_function_args (se, expr, args, 4);
5183 = gfc_build_compare_string (args[0], args[1], args[2], args[3],
5184 expr->value.function.actual->expr->ts.kind,
5186 se->expr = fold_build2_loc (input_location, op,
5187 gfc_typenode_for_spec (&expr->ts), se->expr,
5188 build_int_cst (TREE_TYPE (se->expr), 0));
5191 /* Generate a call to the adjustl/adjustr library function. */
5193 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
5201 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
5204 type = TREE_TYPE (args[2]);
5205 var = gfc_conv_string_tmp (se, type, len);
5208 tmp = build_call_expr_loc (input_location,
5209 fndecl, 3, args[0], args[1], args[2]);
5210 gfc_add_expr_to_block (&se->pre, tmp);
5212 se->string_length = len;
5216 /* Generate code for the TRANSFER intrinsic:
5218 DEST = TRANSFER (SOURCE, MOLD)
5220 typeof<DEST> = typeof<MOLD>
5225 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
5227 typeof<DEST> = typeof<MOLD>
5229 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
5230 sizeof (DEST(0) * SIZE). */
5232 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
5248 gfc_actual_arglist *arg;
5258 info = &se->ss->data.info;
5260 /* Convert SOURCE. The output from this stage is:-
5261 source_bytes = length of the source in bytes
5262 source = pointer to the source data. */
5263 arg = expr->value.function.actual;
5265 /* Ensure double transfer through LOGICAL preserves all
5267 if (arg->expr->expr_type == EXPR_FUNCTION
5268 && arg->expr->value.function.esym == NULL
5269 && arg->expr->value.function.isym != NULL
5270 && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
5271 && arg->expr->ts.type == BT_LOGICAL
5272 && expr->ts.type != arg->expr->ts.type)
5273 arg->expr->value.function.name = "__transfer_in_transfer";
5275 gfc_init_se (&argse, NULL);
5276 ss = gfc_walk_expr (arg->expr);
5278 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
5280 /* Obtain the pointer to source and the length of source in bytes. */
5281 if (ss == gfc_ss_terminator)
5283 gfc_conv_expr_reference (&argse, arg->expr);
5284 source = argse.expr;
5286 source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5289 /* Obtain the source word length. */
5290 if (arg->expr->ts.type == BT_CHARACTER)
5291 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
5292 argse.string_length);
5294 tmp = fold_convert (gfc_array_index_type,
5295 size_in_bytes (source_type));
5299 argse.want_pointer = 0;
5300 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
5301 source = gfc_conv_descriptor_data_get (argse.expr);
5302 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
5304 /* Repack the source if not a full variable array. */
5305 if (arg->expr->expr_type == EXPR_VARIABLE
5306 && arg->expr->ref->u.ar.type != AR_FULL)
5308 tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
5310 if (gfc_option.warn_array_temp)
5311 gfc_warning ("Creating array temporary at %L", &expr->where);
5313 source = build_call_expr_loc (input_location,
5314 gfor_fndecl_in_pack, 1, tmp);
5315 source = gfc_evaluate_now (source, &argse.pre);
5317 /* Free the temporary. */
5318 gfc_start_block (&block);
5319 tmp = gfc_call_free (convert (pvoid_type_node, source));
5320 gfc_add_expr_to_block (&block, tmp);
5321 stmt = gfc_finish_block (&block);
5323 /* Clean up if it was repacked. */
5324 gfc_init_block (&block);
5325 tmp = gfc_conv_array_data (argse.expr);
5326 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5328 tmp = build3_v (COND_EXPR, tmp, stmt,
5329 build_empty_stmt (input_location));
5330 gfc_add_expr_to_block (&block, tmp);
5331 gfc_add_block_to_block (&block, &se->post);
5332 gfc_init_block (&se->post);
5333 gfc_add_block_to_block (&se->post, &block);
5336 /* Obtain the source word length. */
5337 if (arg->expr->ts.type == BT_CHARACTER)
5338 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
5339 argse.string_length);
5341 tmp = fold_convert (gfc_array_index_type,
5342 size_in_bytes (source_type));
5344 /* Obtain the size of the array in bytes. */
5345 extent = gfc_create_var (gfc_array_index_type, NULL);
5346 for (n = 0; n < arg->expr->rank; n++)
5349 idx = gfc_rank_cst[n];
5350 gfc_add_modify (&argse.pre, source_bytes, tmp);
5351 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
5352 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
5353 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5354 gfc_array_index_type, upper, lower);
5355 gfc_add_modify (&argse.pre, extent, tmp);
5356 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5357 gfc_array_index_type, extent,
5358 gfc_index_one_node);
5359 tmp = fold_build2_loc (input_location, MULT_EXPR,
5360 gfc_array_index_type, tmp, source_bytes);
5364 gfc_add_modify (&argse.pre, source_bytes, tmp);
5365 gfc_add_block_to_block (&se->pre, &argse.pre);
5366 gfc_add_block_to_block (&se->post, &argse.post);
5368 /* Now convert MOLD. The outputs are:
5369 mold_type = the TREE type of MOLD
5370 dest_word_len = destination word length in bytes. */
5373 gfc_init_se (&argse, NULL);
5374 ss = gfc_walk_expr (arg->expr);
5376 scalar_mold = arg->expr->rank == 0;
5378 if (ss == gfc_ss_terminator)
5380 gfc_conv_expr_reference (&argse, arg->expr);
5381 mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5386 gfc_init_se (&argse, NULL);
5387 argse.want_pointer = 0;
5388 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
5389 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
5392 gfc_add_block_to_block (&se->pre, &argse.pre);
5393 gfc_add_block_to_block (&se->post, &argse.post);
5395 if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
5397 /* If this TRANSFER is nested in another TRANSFER, use a type
5398 that preserves all bits. */
5399 if (arg->expr->ts.type == BT_LOGICAL)
5400 mold_type = gfc_get_int_type (arg->expr->ts.kind);
5403 if (arg->expr->ts.type == BT_CHARACTER)
5405 tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
5406 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
5409 tmp = fold_convert (gfc_array_index_type,
5410 size_in_bytes (mold_type));
5412 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
5413 gfc_add_modify (&se->pre, dest_word_len, tmp);
5415 /* Finally convert SIZE, if it is present. */
5417 size_words = gfc_create_var (gfc_array_index_type, NULL);
5421 gfc_init_se (&argse, NULL);
5422 gfc_conv_expr_reference (&argse, arg->expr);
5423 tmp = convert (gfc_array_index_type,
5424 build_fold_indirect_ref_loc (input_location,
5426 gfc_add_block_to_block (&se->pre, &argse.pre);
5427 gfc_add_block_to_block (&se->post, &argse.post);
5432 /* Separate array and scalar results. */
5433 if (scalar_mold && tmp == NULL_TREE)
5434 goto scalar_transfer;
5436 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
5437 if (tmp != NULL_TREE)
5438 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5439 tmp, dest_word_len);
5443 gfc_add_modify (&se->pre, size_bytes, tmp);
5444 gfc_add_modify (&se->pre, size_words,
5445 fold_build2_loc (input_location, CEIL_DIV_EXPR,
5446 gfc_array_index_type,
5447 size_bytes, dest_word_len));
5449 /* Evaluate the bounds of the result. If the loop range exists, we have
5450 to check if it is too large. If so, we modify loop->to be consistent
5451 with min(size, size(source)). Otherwise, size is made consistent with
5452 the loop range, so that the right number of bytes is transferred.*/
5453 n = se->loop->order[0];
5454 if (se->loop->to[n] != NULL_TREE)
5456 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5457 se->loop->to[n], se->loop->from[n]);
5458 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5459 tmp, gfc_index_one_node);
5460 tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
5462 gfc_add_modify (&se->pre, size_words, tmp);
5463 gfc_add_modify (&se->pre, size_bytes,
5464 fold_build2_loc (input_location, MULT_EXPR,
5465 gfc_array_index_type,
5466 size_words, dest_word_len));
5467 upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5468 size_words, se->loop->from[n]);
5469 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5470 upper, gfc_index_one_node);
5474 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5475 size_words, gfc_index_one_node);
5476 se->loop->from[n] = gfc_index_zero_node;
5479 se->loop->to[n] = upper;
5481 /* Build a destination descriptor, using the pointer, source, as the
5483 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
5484 info, mold_type, NULL_TREE, false, true, false,
5487 /* Cast the pointer to the result. */
5488 tmp = gfc_conv_descriptor_data_get (info->descriptor);
5489 tmp = fold_convert (pvoid_type_node, tmp);
5491 /* Use memcpy to do the transfer. */
5492 tmp = build_call_expr_loc (input_location,
5493 built_in_decls[BUILT_IN_MEMCPY],
5496 fold_convert (pvoid_type_node, source),
5497 fold_build2_loc (input_location, MIN_EXPR,
5498 gfc_array_index_type,
5499 size_bytes, source_bytes));
5500 gfc_add_expr_to_block (&se->pre, tmp);
5502 se->expr = info->descriptor;
5503 if (expr->ts.type == BT_CHARACTER)
5504 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
5508 /* Deal with scalar results. */
5510 extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
5511 dest_word_len, source_bytes);
5512 extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5513 extent, gfc_index_zero_node);
5515 if (expr->ts.type == BT_CHARACTER)
5520 ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
5521 tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
5524 /* If source is longer than the destination, use a pointer to
5525 the source directly. */
5526 gfc_init_block (&block);
5527 gfc_add_modify (&block, tmpdecl, ptr);
5528 direct = gfc_finish_block (&block);
5530 /* Otherwise, allocate a string with the length of the destination
5531 and copy the source into it. */
5532 gfc_init_block (&block);
5533 tmp = gfc_get_pchar_type (expr->ts.kind);
5534 tmp = gfc_call_malloc (&block, tmp, dest_word_len);
5535 gfc_add_modify (&block, tmpdecl,
5536 fold_convert (TREE_TYPE (ptr), tmp));
5537 tmp = build_call_expr_loc (input_location,
5538 built_in_decls[BUILT_IN_MEMCPY], 3,
5539 fold_convert (pvoid_type_node, tmpdecl),
5540 fold_convert (pvoid_type_node, ptr),
5542 gfc_add_expr_to_block (&block, tmp);
5543 indirect = gfc_finish_block (&block);
5545 /* Wrap it up with the condition. */
5546 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
5547 dest_word_len, source_bytes);
5548 tmp = build3_v (COND_EXPR, tmp, direct, indirect);
5549 gfc_add_expr_to_block (&se->pre, tmp);
5552 se->string_length = dest_word_len;
5556 tmpdecl = gfc_create_var (mold_type, "transfer");
5558 ptr = convert (build_pointer_type (mold_type), source);
5560 /* Use memcpy to do the transfer. */
5561 tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
5562 tmp = build_call_expr_loc (input_location,
5563 built_in_decls[BUILT_IN_MEMCPY], 3,
5564 fold_convert (pvoid_type_node, tmp),
5565 fold_convert (pvoid_type_node, ptr),
5567 gfc_add_expr_to_block (&se->pre, tmp);
5574 /* Generate code for the ALLOCATED intrinsic.
5575 Generate inline code that directly check the address of the argument. */
5578 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
5580 gfc_actual_arglist *arg1;
5585 gfc_init_se (&arg1se, NULL);
5586 arg1 = expr->value.function.actual;
5587 ss1 = gfc_walk_expr (arg1->expr);
5589 if (ss1 == gfc_ss_terminator)
5591 /* Allocatable scalar. */
5592 arg1se.want_pointer = 1;
5593 if (arg1->expr->ts.type == BT_CLASS)
5594 gfc_add_data_component (arg1->expr);
5595 gfc_conv_expr (&arg1se, arg1->expr);
5600 /* Allocatable array. */
5601 arg1se.descriptor_only = 1;
5602 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
5603 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
5606 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
5607 fold_convert (TREE_TYPE (tmp), null_pointer_node));
5608 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
5612 /* Generate code for the ASSOCIATED intrinsic.
5613 If both POINTER and TARGET are arrays, generate a call to library function
5614 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
5615 In other cases, generate inline code that directly compare the address of
5616 POINTER with the address of TARGET. */
5619 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
5621 gfc_actual_arglist *arg1;
5622 gfc_actual_arglist *arg2;
5627 tree nonzero_charlen;
5628 tree nonzero_arraylen;
5631 gfc_init_se (&arg1se, NULL);
5632 gfc_init_se (&arg2se, NULL);
5633 arg1 = expr->value.function.actual;
5634 if (arg1->expr->ts.type == BT_CLASS)
5635 gfc_add_data_component (arg1->expr);
5637 ss1 = gfc_walk_expr (arg1->expr);
5641 /* No optional target. */
5642 if (ss1 == gfc_ss_terminator)
5644 /* A pointer to a scalar. */
5645 arg1se.want_pointer = 1;
5646 gfc_conv_expr (&arg1se, arg1->expr);
5651 /* A pointer to an array. */
5652 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
5653 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
5655 gfc_add_block_to_block (&se->pre, &arg1se.pre);
5656 gfc_add_block_to_block (&se->post, &arg1se.post);
5657 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2,
5658 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
5663 /* An optional target. */
5664 if (arg2->expr->ts.type == BT_CLASS)
5665 gfc_add_data_component (arg2->expr);
5666 ss2 = gfc_walk_expr (arg2->expr);
5668 nonzero_charlen = NULL_TREE;
5669 if (arg1->expr->ts.type == BT_CHARACTER)
5670 nonzero_charlen = fold_build2_loc (input_location, NE_EXPR,
5672 arg1->expr->ts.u.cl->backend_decl,
5675 if (ss1 == gfc_ss_terminator)
5677 /* A pointer to a scalar. */
5678 gcc_assert (ss2 == gfc_ss_terminator);
5679 arg1se.want_pointer = 1;
5680 gfc_conv_expr (&arg1se, arg1->expr);
5681 arg2se.want_pointer = 1;
5682 gfc_conv_expr (&arg2se, arg2->expr);
5683 gfc_add_block_to_block (&se->pre, &arg1se.pre);
5684 gfc_add_block_to_block (&se->post, &arg1se.post);
5685 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5686 arg1se.expr, arg2se.expr);
5687 tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5688 arg1se.expr, null_pointer_node);
5689 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5690 boolean_type_node, tmp, tmp2);
5694 /* An array pointer of zero length is not associated if target is
5696 arg1se.descriptor_only = 1;
5697 gfc_conv_expr_lhs (&arg1se, arg1->expr);
5698 tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
5699 gfc_rank_cst[arg1->expr->rank - 1]);
5700 nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
5701 boolean_type_node, tmp,
5702 build_int_cst (TREE_TYPE (tmp), 0));
5704 /* A pointer to an array, call library function _gfor_associated. */
5705 gcc_assert (ss2 != gfc_ss_terminator);
5706 arg1se.want_pointer = 1;
5707 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
5709 arg2se.want_pointer = 1;
5710 gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
5711 gfc_add_block_to_block (&se->pre, &arg2se.pre);
5712 gfc_add_block_to_block (&se->post, &arg2se.post);
5713 se->expr = build_call_expr_loc (input_location,
5714 gfor_fndecl_associated, 2,
5715 arg1se.expr, arg2se.expr);
5716 se->expr = convert (boolean_type_node, se->expr);
5717 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5718 boolean_type_node, se->expr,
5722 /* If target is present zero character length pointers cannot
5724 if (nonzero_charlen != NULL_TREE)
5725 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5727 se->expr, nonzero_charlen);
5730 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
5734 /* Generate code for the SAME_TYPE_AS intrinsic.
5735 Generate inline code that directly checks the vindices. */
5738 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
5744 gfc_init_se (&se1, NULL);
5745 gfc_init_se (&se2, NULL);
5747 a = expr->value.function.actual->expr;
5748 b = expr->value.function.actual->next->expr;
5750 if (a->ts.type == BT_CLASS)
5752 gfc_add_vptr_component (a);
5753 gfc_add_hash_component (a);
5755 else if (a->ts.type == BT_DERIVED)
5756 a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5757 a->ts.u.derived->hash_value);
5759 if (b->ts.type == BT_CLASS)
5761 gfc_add_vptr_component (b);
5762 gfc_add_hash_component (b);
5764 else if (b->ts.type == BT_DERIVED)
5765 b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5766 b->ts.u.derived->hash_value);
5768 gfc_conv_expr (&se1, a);
5769 gfc_conv_expr (&se2, b);
5771 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5772 se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
5773 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
5777 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
5780 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
5784 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5785 se->expr = build_call_expr_loc (input_location,
5786 gfor_fndecl_sc_kind, 2, args[0], args[1]);
5787 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
5791 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
5794 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
5798 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5800 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
5801 type = gfc_get_int_type (4);
5802 arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
5804 /* Convert it to the required type. */
5805 type = gfc_typenode_for_spec (&expr->ts);
5806 se->expr = build_call_expr_loc (input_location,
5807 gfor_fndecl_si_kind, 1, arg);
5808 se->expr = fold_convert (type, se->expr);
5812 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
5815 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
5817 gfc_actual_arglist *actual;
5820 VEC(tree,gc) *args = NULL;
5822 for (actual = expr->value.function.actual; actual; actual = actual->next)
5824 gfc_init_se (&argse, se);
5826 /* Pass a NULL pointer for an absent arg. */
5827 if (actual->expr == NULL)
5828 argse.expr = null_pointer_node;
5834 if (actual->expr->ts.kind != gfc_c_int_kind)
5836 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
5837 ts.type = BT_INTEGER;
5838 ts.kind = gfc_c_int_kind;
5839 gfc_convert_type (actual->expr, &ts, 2);
5841 gfc_conv_expr_reference (&argse, actual->expr);
5844 gfc_add_block_to_block (&se->pre, &argse.pre);
5845 gfc_add_block_to_block (&se->post, &argse.post);
5846 VEC_safe_push (tree, gc, args, argse.expr);
5849 /* Convert it to the required type. */
5850 type = gfc_typenode_for_spec (&expr->ts);
5851 se->expr = build_call_expr_loc_vec (input_location,
5852 gfor_fndecl_sr_kind, args);
5853 se->expr = fold_convert (type, se->expr);
5857 /* Generate code for TRIM (A) intrinsic function. */
5860 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
5870 unsigned int num_args;
5872 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
5873 args = XALLOCAVEC (tree, num_args);
5875 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
5876 addr = gfc_build_addr_expr (ppvoid_type_node, var);
5877 len = gfc_create_var (gfc_charlen_type_node, "len");
5879 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
5880 args[0] = gfc_build_addr_expr (NULL_TREE, len);
5883 if (expr->ts.kind == 1)
5884 function = gfor_fndecl_string_trim;
5885 else if (expr->ts.kind == 4)
5886 function = gfor_fndecl_string_trim_char4;
5890 fndecl = build_addr (function, current_function_decl);
5891 tmp = build_call_array_loc (input_location,
5892 TREE_TYPE (TREE_TYPE (function)), fndecl,
5894 gfc_add_expr_to_block (&se->pre, tmp);
5896 /* Free the temporary afterwards, if necessary. */
5897 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
5898 len, build_int_cst (TREE_TYPE (len), 0));
5899 tmp = gfc_call_free (var);
5900 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
5901 gfc_add_expr_to_block (&se->post, tmp);
5904 se->string_length = len;
5908 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
5911 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
5913 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
5914 tree type, cond, tmp, count, exit_label, n, max, largest;
5916 stmtblock_t block, body;
5919 /* We store in charsize the size of a character. */
5920 i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
5921 size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
5923 /* Get the arguments. */
5924 gfc_conv_intrinsic_function_args (se, expr, args, 3);
5925 slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
5927 ncopies = gfc_evaluate_now (args[2], &se->pre);
5928 ncopies_type = TREE_TYPE (ncopies);
5930 /* Check that NCOPIES is not negative. */
5931 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, ncopies,
5932 build_int_cst (ncopies_type, 0));
5933 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
5934 "Argument NCOPIES of REPEAT intrinsic is negative "
5935 "(its value is %lld)",
5936 fold_convert (long_integer_type_node, ncopies));
5938 /* If the source length is zero, any non negative value of NCOPIES
5939 is valid, and nothing happens. */
5940 n = gfc_create_var (ncopies_type, "ncopies");
5941 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
5942 build_int_cst (size_type_node, 0));
5943 tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
5944 build_int_cst (ncopies_type, 0), ncopies);
5945 gfc_add_modify (&se->pre, n, tmp);
5948 /* Check that ncopies is not too large: ncopies should be less than
5949 (or equal to) MAX / slen, where MAX is the maximal integer of
5950 the gfc_charlen_type_node type. If slen == 0, we need a special
5951 case to avoid the division by zero. */
5952 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5953 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
5954 max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
5955 fold_convert (size_type_node, max), slen);
5956 largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
5957 ? size_type_node : ncopies_type;
5958 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
5959 fold_convert (largest, ncopies),
5960 fold_convert (largest, max));
5961 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
5962 build_int_cst (size_type_node, 0));
5963 cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp,
5964 boolean_false_node, cond);
5965 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
5966 "Argument NCOPIES of REPEAT intrinsic is too large");
5968 /* Compute the destination length. */
5969 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
5970 fold_convert (gfc_charlen_type_node, slen),
5971 fold_convert (gfc_charlen_type_node, ncopies));
5972 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
5973 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
5975 /* Generate the code to do the repeat operation:
5976 for (i = 0; i < ncopies; i++)
5977 memmove (dest + (i * slen * size), src, slen*size); */
5978 gfc_start_block (&block);
5979 count = gfc_create_var (ncopies_type, "count");
5980 gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
5981 exit_label = gfc_build_label_decl (NULL_TREE);
5983 /* Start the loop body. */
5984 gfc_start_block (&body);
5986 /* Exit the loop if count >= ncopies. */
5987 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, count,
5989 tmp = build1_v (GOTO_EXPR, exit_label);
5990 TREE_USED (exit_label) = 1;
5991 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
5992 build_empty_stmt (input_location));
5993 gfc_add_expr_to_block (&body, tmp);
5995 /* Call memmove (dest + (i*slen*size), src, slen*size). */
5996 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
5997 fold_convert (gfc_charlen_type_node, slen),
5998 fold_convert (gfc_charlen_type_node, count));
5999 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
6000 tmp, fold_convert (gfc_charlen_type_node, size));
6001 tmp = fold_build_pointer_plus_loc (input_location,
6002 fold_convert (pvoid_type_node, dest), tmp);
6003 tmp = build_call_expr_loc (input_location,
6004 built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
6005 fold_build2_loc (input_location, MULT_EXPR,
6006 size_type_node, slen,
6007 fold_convert (size_type_node,
6009 gfc_add_expr_to_block (&body, tmp);
6011 /* Increment count. */
6012 tmp = fold_build2_loc (input_location, PLUS_EXPR, ncopies_type,
6013 count, build_int_cst (TREE_TYPE (count), 1));
6014 gfc_add_modify (&body, count, tmp);
6016 /* Build the loop. */
6017 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
6018 gfc_add_expr_to_block (&block, tmp);
6020 /* Add the exit label. */
6021 tmp = build1_v (LABEL_EXPR, exit_label);
6022 gfc_add_expr_to_block (&block, tmp);
6024 /* Finish the block. */
6025 tmp = gfc_finish_block (&block);
6026 gfc_add_expr_to_block (&se->pre, tmp);
6028 /* Set the result value. */
6030 se->string_length = dlen;
6034 /* Generate code for the IARGC intrinsic. */
6037 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
6043 /* Call the library function. This always returns an INTEGER(4). */
6044 fndecl = gfor_fndecl_iargc;
6045 tmp = build_call_expr_loc (input_location,
6048 /* Convert it to the required type. */
6049 type = gfc_typenode_for_spec (&expr->ts);
6050 tmp = fold_convert (type, tmp);
6056 /* The loc intrinsic returns the address of its argument as
6057 gfc_index_integer_kind integer. */
6060 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
6066 gcc_assert (!se->ss);
6068 arg_expr = expr->value.function.actual->expr;
6069 ss = gfc_walk_expr (arg_expr);
6070 if (ss == gfc_ss_terminator)
6071 gfc_conv_expr_reference (se, arg_expr);
6073 gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL);
6074 se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
6076 /* Create a temporary variable for loc return value. Without this,
6077 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
6078 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
6079 gfc_add_modify (&se->pre, temp_var, se->expr);
6080 se->expr = temp_var;
6083 /* Generate code for an intrinsic function. Some map directly to library
6084 calls, others get special handling. In some cases the name of the function
6085 used depends on the type specifiers. */
6088 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
6094 name = &expr->value.function.name[2];
6098 lib = gfc_is_intrinsic_libcall (expr);
6102 se->ignore_optional = 1;
6104 switch (expr->value.function.isym->id)
6106 case GFC_ISYM_EOSHIFT:
6108 case GFC_ISYM_RESHAPE:
6109 /* For all of those the first argument specifies the type and the
6110 third is optional. */
6111 conv_generic_with_optional_char_arg (se, expr, 1, 3);
6115 gfc_conv_intrinsic_funcall (se, expr);
6123 switch (expr->value.function.isym->id)
6128 case GFC_ISYM_REPEAT:
6129 gfc_conv_intrinsic_repeat (se, expr);
6133 gfc_conv_intrinsic_trim (se, expr);
6136 case GFC_ISYM_SC_KIND:
6137 gfc_conv_intrinsic_sc_kind (se, expr);
6140 case GFC_ISYM_SI_KIND:
6141 gfc_conv_intrinsic_si_kind (se, expr);
6144 case GFC_ISYM_SR_KIND:
6145 gfc_conv_intrinsic_sr_kind (se, expr);
6148 case GFC_ISYM_EXPONENT:
6149 gfc_conv_intrinsic_exponent (se, expr);
6153 kind = expr->value.function.actual->expr->ts.kind;
6155 fndecl = gfor_fndecl_string_scan;
6157 fndecl = gfor_fndecl_string_scan_char4;
6161 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
6164 case GFC_ISYM_VERIFY:
6165 kind = expr->value.function.actual->expr->ts.kind;
6167 fndecl = gfor_fndecl_string_verify;
6169 fndecl = gfor_fndecl_string_verify_char4;
6173 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
6176 case GFC_ISYM_ALLOCATED:
6177 gfc_conv_allocated (se, expr);
6180 case GFC_ISYM_ASSOCIATED:
6181 gfc_conv_associated(se, expr);
6184 case GFC_ISYM_SAME_TYPE_AS:
6185 gfc_conv_same_type_as (se, expr);
6189 gfc_conv_intrinsic_abs (se, expr);
6192 case GFC_ISYM_ADJUSTL:
6193 if (expr->ts.kind == 1)
6194 fndecl = gfor_fndecl_adjustl;
6195 else if (expr->ts.kind == 4)
6196 fndecl = gfor_fndecl_adjustl_char4;
6200 gfc_conv_intrinsic_adjust (se, expr, fndecl);
6203 case GFC_ISYM_ADJUSTR:
6204 if (expr->ts.kind == 1)
6205 fndecl = gfor_fndecl_adjustr;
6206 else if (expr->ts.kind == 4)
6207 fndecl = gfor_fndecl_adjustr_char4;
6211 gfc_conv_intrinsic_adjust (se, expr, fndecl);
6214 case GFC_ISYM_AIMAG:
6215 gfc_conv_intrinsic_imagpart (se, expr);
6219 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
6223 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
6226 case GFC_ISYM_ANINT:
6227 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
6231 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
6235 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
6238 case GFC_ISYM_BTEST:
6239 gfc_conv_intrinsic_btest (se, expr);
6243 gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
6247 gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
6251 gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
6255 gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
6258 case GFC_ISYM_ACHAR:
6260 gfc_conv_intrinsic_char (se, expr);
6263 case GFC_ISYM_CONVERSION:
6265 case GFC_ISYM_LOGICAL:
6267 gfc_conv_intrinsic_conversion (se, expr);
6270 /* Integer conversions are handled separately to make sure we get the
6271 correct rounding mode. */
6276 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
6280 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
6283 case GFC_ISYM_CEILING:
6284 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
6287 case GFC_ISYM_FLOOR:
6288 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
6292 gfc_conv_intrinsic_mod (se, expr, 0);
6295 case GFC_ISYM_MODULO:
6296 gfc_conv_intrinsic_mod (se, expr, 1);
6299 case GFC_ISYM_CMPLX:
6300 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
6303 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
6304 gfc_conv_intrinsic_iargc (se, expr);
6307 case GFC_ISYM_COMPLEX:
6308 gfc_conv_intrinsic_cmplx (se, expr, 1);
6311 case GFC_ISYM_CONJG:
6312 gfc_conv_intrinsic_conjg (se, expr);
6315 case GFC_ISYM_COUNT:
6316 gfc_conv_intrinsic_count (se, expr);
6319 case GFC_ISYM_CTIME:
6320 gfc_conv_intrinsic_ctime (se, expr);
6324 gfc_conv_intrinsic_dim (se, expr);
6327 case GFC_ISYM_DOT_PRODUCT:
6328 gfc_conv_intrinsic_dot_product (se, expr);
6331 case GFC_ISYM_DPROD:
6332 gfc_conv_intrinsic_dprod (se, expr);
6335 case GFC_ISYM_DSHIFTL:
6336 gfc_conv_intrinsic_dshift (se, expr, true);
6339 case GFC_ISYM_DSHIFTR:
6340 gfc_conv_intrinsic_dshift (se, expr, false);
6343 case GFC_ISYM_FDATE:
6344 gfc_conv_intrinsic_fdate (se, expr);
6347 case GFC_ISYM_FRACTION:
6348 gfc_conv_intrinsic_fraction (se, expr);
6352 gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
6356 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
6360 gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
6363 case GFC_ISYM_IBCLR:
6364 gfc_conv_intrinsic_singlebitop (se, expr, 0);
6367 case GFC_ISYM_IBITS:
6368 gfc_conv_intrinsic_ibits (se, expr);
6371 case GFC_ISYM_IBSET:
6372 gfc_conv_intrinsic_singlebitop (se, expr, 1);
6375 case GFC_ISYM_IACHAR:
6376 case GFC_ISYM_ICHAR:
6377 /* We assume ASCII character sequence. */
6378 gfc_conv_intrinsic_ichar (se, expr);
6381 case GFC_ISYM_IARGC:
6382 gfc_conv_intrinsic_iargc (se, expr);
6386 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
6389 case GFC_ISYM_INDEX:
6390 kind = expr->value.function.actual->expr->ts.kind;
6392 fndecl = gfor_fndecl_string_index;
6394 fndecl = gfor_fndecl_string_index_char4;
6398 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
6402 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
6405 case GFC_ISYM_IPARITY:
6406 gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
6409 case GFC_ISYM_IS_IOSTAT_END:
6410 gfc_conv_has_intvalue (se, expr, LIBERROR_END);
6413 case GFC_ISYM_IS_IOSTAT_EOR:
6414 gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
6417 case GFC_ISYM_ISNAN:
6418 gfc_conv_intrinsic_isnan (se, expr);
6421 case GFC_ISYM_LSHIFT:
6422 gfc_conv_intrinsic_shift (se, expr, false, false);
6425 case GFC_ISYM_RSHIFT:
6426 gfc_conv_intrinsic_shift (se, expr, true, true);
6429 case GFC_ISYM_SHIFTA:
6430 gfc_conv_intrinsic_shift (se, expr, true, true);
6433 case GFC_ISYM_SHIFTL:
6434 gfc_conv_intrinsic_shift (se, expr, false, false);
6437 case GFC_ISYM_SHIFTR:
6438 gfc_conv_intrinsic_shift (se, expr, true, false);
6441 case GFC_ISYM_ISHFT:
6442 gfc_conv_intrinsic_ishft (se, expr);
6445 case GFC_ISYM_ISHFTC:
6446 gfc_conv_intrinsic_ishftc (se, expr);
6449 case GFC_ISYM_LEADZ:
6450 gfc_conv_intrinsic_leadz (se, expr);
6453 case GFC_ISYM_TRAILZ:
6454 gfc_conv_intrinsic_trailz (se, expr);
6457 case GFC_ISYM_POPCNT:
6458 gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
6461 case GFC_ISYM_POPPAR:
6462 gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
6465 case GFC_ISYM_LBOUND:
6466 gfc_conv_intrinsic_bound (se, expr, 0);
6469 case GFC_ISYM_LCOBOUND:
6470 conv_intrinsic_cobound (se, expr);
6473 case GFC_ISYM_TRANSPOSE:
6474 /* The scalarizer has already been set up for reversed dimension access
6475 order ; now we just get the argument value normally. */
6476 gfc_conv_expr (se, expr->value.function.actual->expr);
6480 gfc_conv_intrinsic_len (se, expr);
6483 case GFC_ISYM_LEN_TRIM:
6484 gfc_conv_intrinsic_len_trim (se, expr);
6488 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
6492 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
6496 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
6500 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
6503 case GFC_ISYM_MASKL:
6504 gfc_conv_intrinsic_mask (se, expr, 1);
6507 case GFC_ISYM_MASKR:
6508 gfc_conv_intrinsic_mask (se, expr, 0);
6512 if (expr->ts.type == BT_CHARACTER)
6513 gfc_conv_intrinsic_minmax_char (se, expr, 1);
6515 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
6518 case GFC_ISYM_MAXLOC:
6519 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
6522 case GFC_ISYM_MAXVAL:
6523 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
6526 case GFC_ISYM_MERGE:
6527 gfc_conv_intrinsic_merge (se, expr);
6530 case GFC_ISYM_MERGE_BITS:
6531 gfc_conv_intrinsic_merge_bits (se, expr);
6535 if (expr->ts.type == BT_CHARACTER)
6536 gfc_conv_intrinsic_minmax_char (se, expr, -1);
6538 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
6541 case GFC_ISYM_MINLOC:
6542 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
6545 case GFC_ISYM_MINVAL:
6546 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
6549 case GFC_ISYM_NEAREST:
6550 gfc_conv_intrinsic_nearest (se, expr);
6553 case GFC_ISYM_NORM2:
6554 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
6558 gfc_conv_intrinsic_not (se, expr);
6562 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
6565 case GFC_ISYM_PARITY:
6566 gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
6569 case GFC_ISYM_PRESENT:
6570 gfc_conv_intrinsic_present (se, expr);
6573 case GFC_ISYM_PRODUCT:
6574 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
6577 case GFC_ISYM_RRSPACING:
6578 gfc_conv_intrinsic_rrspacing (se, expr);
6581 case GFC_ISYM_SET_EXPONENT:
6582 gfc_conv_intrinsic_set_exponent (se, expr);
6585 case GFC_ISYM_SCALE:
6586 gfc_conv_intrinsic_scale (se, expr);
6590 gfc_conv_intrinsic_sign (se, expr);
6594 gfc_conv_intrinsic_size (se, expr);
6597 case GFC_ISYM_SIZEOF:
6598 case GFC_ISYM_C_SIZEOF:
6599 gfc_conv_intrinsic_sizeof (se, expr);
6602 case GFC_ISYM_STORAGE_SIZE:
6603 gfc_conv_intrinsic_storage_size (se, expr);
6606 case GFC_ISYM_SPACING:
6607 gfc_conv_intrinsic_spacing (se, expr);
6611 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
6614 case GFC_ISYM_TRANSFER:
6615 if (se->ss && se->ss->useflags)
6616 /* Access the previously obtained result. */
6617 gfc_conv_tmp_array_ref (se);
6619 gfc_conv_intrinsic_transfer (se, expr);
6622 case GFC_ISYM_TTYNAM:
6623 gfc_conv_intrinsic_ttynam (se, expr);
6626 case GFC_ISYM_UBOUND:
6627 gfc_conv_intrinsic_bound (se, expr, 1);
6630 case GFC_ISYM_UCOBOUND:
6631 conv_intrinsic_cobound (se, expr);
6635 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
6639 gfc_conv_intrinsic_loc (se, expr);
6642 case GFC_ISYM_THIS_IMAGE:
6643 /* For num_images() == 1, handle as LCOBOUND. */
6644 if (expr->value.function.actual->expr
6645 && gfc_option.coarray == GFC_FCOARRAY_SINGLE)
6646 conv_intrinsic_cobound (se, expr);
6648 trans_this_image (se, expr);
6651 case GFC_ISYM_IMAGE_INDEX:
6652 trans_image_index (se, expr);
6655 case GFC_ISYM_NUM_IMAGES:
6656 trans_num_images (se);
6659 case GFC_ISYM_ACCESS:
6660 case GFC_ISYM_CHDIR:
6661 case GFC_ISYM_CHMOD:
6662 case GFC_ISYM_DTIME:
6663 case GFC_ISYM_ETIME:
6664 case GFC_ISYM_EXTENDS_TYPE_OF:
6666 case GFC_ISYM_FGETC:
6669 case GFC_ISYM_FPUTC:
6670 case GFC_ISYM_FSTAT:
6671 case GFC_ISYM_FTELL:
6672 case GFC_ISYM_GETCWD:
6673 case GFC_ISYM_GETGID:
6674 case GFC_ISYM_GETPID:
6675 case GFC_ISYM_GETUID:
6676 case GFC_ISYM_HOSTNM:
6678 case GFC_ISYM_IERRNO:
6679 case GFC_ISYM_IRAND:
6680 case GFC_ISYM_ISATTY:
6683 case GFC_ISYM_LSTAT:
6684 case GFC_ISYM_MALLOC:
6685 case GFC_ISYM_MATMUL:
6686 case GFC_ISYM_MCLOCK:
6687 case GFC_ISYM_MCLOCK8:
6689 case GFC_ISYM_RENAME:
6690 case GFC_ISYM_SECOND:
6691 case GFC_ISYM_SECNDS:
6692 case GFC_ISYM_SIGNAL:
6694 case GFC_ISYM_SYMLNK:
6695 case GFC_ISYM_SYSTEM:
6697 case GFC_ISYM_TIME8:
6698 case GFC_ISYM_UMASK:
6699 case GFC_ISYM_UNLINK:
6701 gfc_conv_intrinsic_funcall (se, expr);
6704 case GFC_ISYM_EOSHIFT:
6706 case GFC_ISYM_RESHAPE:
6707 /* For those, expr->rank should always be >0 and thus the if above the
6708 switch should have matched. */
6713 gfc_conv_intrinsic_lib_function (se, expr);
6720 walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
6722 gfc_ss *arg_ss, *tmp_ss;
6723 gfc_actual_arglist *arg;
6725 arg = expr->value.function.actual;
6727 gcc_assert (arg->expr);
6729 arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
6730 gcc_assert (arg_ss != gfc_ss_terminator);
6732 for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
6734 if (tmp_ss->type != GFC_SS_SCALAR
6735 && tmp_ss->type != GFC_SS_REFERENCE)
6740 info = &tmp_ss->data.info;
6741 gcc_assert (info->dimen == 2);
6743 /* We just invert dimensions. */
6744 tmp_dim = info->dim[0];
6745 info->dim[0] = info->dim[1];
6746 info->dim[1] = tmp_dim;
6749 /* Stop when tmp_ss points to the last valid element of the chain... */
6750 if (tmp_ss->next == gfc_ss_terminator)
6754 /* ... so that we can attach the rest of the chain to it. */
6762 walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
6765 switch (expr->value.function.isym->id)
6767 case GFC_ISYM_TRANSPOSE:
6768 return walk_inline_intrinsic_transpose (ss, expr);
6777 /* This generates code to execute before entering the scalarization loop.
6778 Currently does nothing. */
6781 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
6783 switch (ss->expr->value.function.isym->id)
6785 case GFC_ISYM_UBOUND:
6786 case GFC_ISYM_LBOUND:
6787 case GFC_ISYM_UCOBOUND:
6788 case GFC_ISYM_LCOBOUND:
6789 case GFC_ISYM_THIS_IMAGE:
6798 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
6799 are expanded into code inside the scalarization loop. */
6802 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
6804 /* The two argument version returns a scalar. */
6805 if (expr->value.function.actual->next->expr)
6808 return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
6812 /* Walk an intrinsic array libcall. */
6815 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
6817 gcc_assert (expr->rank > 0);
6818 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
6822 /* Return whether the function call expression EXPR will be expanded
6823 inline by gfc_conv_intrinsic_function. */
6826 gfc_inline_intrinsic_function_p (gfc_expr *expr)
6828 if (!expr->value.function.isym)
6831 switch (expr->value.function.isym->id)
6833 case GFC_ISYM_TRANSPOSE:
6842 /* Returns nonzero if the specified intrinsic function call maps directly to
6843 an external library call. Should only be used for functions that return
6847 gfc_is_intrinsic_libcall (gfc_expr * expr)
6849 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
6850 gcc_assert (expr->rank > 0);
6852 if (gfc_inline_intrinsic_function_p (expr))
6855 switch (expr->value.function.isym->id)
6859 case GFC_ISYM_COUNT:
6863 case GFC_ISYM_IPARITY:
6864 case GFC_ISYM_MATMUL:
6865 case GFC_ISYM_MAXLOC:
6866 case GFC_ISYM_MAXVAL:
6867 case GFC_ISYM_MINLOC:
6868 case GFC_ISYM_MINVAL:
6869 case GFC_ISYM_NORM2:
6870 case GFC_ISYM_PARITY:
6871 case GFC_ISYM_PRODUCT:
6873 case GFC_ISYM_SHAPE:
6874 case GFC_ISYM_SPREAD:
6876 /* Ignore absent optional parameters. */
6879 case GFC_ISYM_RESHAPE:
6880 case GFC_ISYM_CSHIFT:
6881 case GFC_ISYM_EOSHIFT:
6883 case GFC_ISYM_UNPACK:
6884 /* Pass absent optional parameters. */
6892 /* Walk an intrinsic function. */
6894 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
6895 gfc_intrinsic_sym * isym)
6899 if (isym->elemental)
6900 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6903 if (expr->rank == 0)
6906 if (gfc_inline_intrinsic_function_p (expr))
6907 return walk_inline_intrinsic_function (ss, expr);
6909 if (gfc_is_intrinsic_libcall (expr))
6910 return gfc_walk_intrinsic_libfunc (ss, expr);
6912 /* Special cases. */
6915 case GFC_ISYM_LBOUND:
6916 case GFC_ISYM_LCOBOUND:
6917 case GFC_ISYM_UBOUND:
6918 case GFC_ISYM_UCOBOUND:
6919 case GFC_ISYM_THIS_IMAGE:
6920 return gfc_walk_intrinsic_bound (ss, expr);
6922 case GFC_ISYM_TRANSFER:
6923 return gfc_walk_intrinsic_libfunc (ss, expr);
6926 /* This probably meant someone forgot to add an intrinsic to the above
6927 list(s) when they implemented it, or something's gone horribly
6935 conv_intrinsic_atomic_def (gfc_code *code)
6940 gfc_init_se (&atom, NULL);
6941 gfc_init_se (&value, NULL);
6942 gfc_conv_expr (&atom, code->ext.actual->expr);
6943 gfc_conv_expr (&value, code->ext.actual->next->expr);
6945 gfc_init_block (&block);
6946 gfc_add_modify (&block, atom.expr,
6947 fold_convert (TREE_TYPE (atom.expr), value.expr));
6948 return gfc_finish_block (&block);
6953 conv_intrinsic_atomic_ref (gfc_code *code)
6958 gfc_init_se (&atom, NULL);
6959 gfc_init_se (&value, NULL);
6960 gfc_conv_expr (&value, code->ext.actual->expr);
6961 gfc_conv_expr (&atom, code->ext.actual->next->expr);
6963 gfc_init_block (&block);
6964 gfc_add_modify (&block, value.expr,
6965 fold_convert (TREE_TYPE (value.expr), atom.expr));
6966 return gfc_finish_block (&block);
6971 conv_intrinsic_move_alloc (gfc_code *code)
6973 if (code->ext.actual->expr->rank == 0)
6975 /* Scalar arguments: Generate pointer assignments. */
6976 gfc_expr *from, *to, *deal;
6981 from = code->ext.actual->expr;
6982 to = code->ext.actual->next->expr;
6984 gfc_start_block (&block);
6986 /* Deallocate 'TO' argument. */
6987 gfc_init_se (&se, NULL);
6988 se.want_pointer = 1;
6989 deal = gfc_copy_expr (to);
6990 if (deal->ts.type == BT_CLASS)
6991 gfc_add_data_component (deal);
6992 gfc_conv_expr (&se, deal);
6993 tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
6995 gfc_add_expr_to_block (&block, tmp);
6996 gfc_free_expr (deal);
6998 if (to->ts.type == BT_CLASS)
6999 tmp = gfc_trans_class_assign (to, from, EXEC_POINTER_ASSIGN);
7001 tmp = gfc_trans_pointer_assignment (to, from);
7002 gfc_add_expr_to_block (&block, tmp);
7004 if (from->ts.type == BT_CLASS)
7005 tmp = gfc_trans_class_assign (from, gfc_get_null_expr (NULL),
7006 EXEC_POINTER_ASSIGN);
7008 tmp = gfc_trans_pointer_assignment (from,
7009 gfc_get_null_expr (NULL));
7010 gfc_add_expr_to_block (&block, tmp);
7012 return gfc_finish_block (&block);
7015 /* Array arguments: Generate library code. */
7016 return gfc_trans_call (code, false, NULL_TREE, NULL_TREE, false);
7021 gfc_conv_intrinsic_subroutine (gfc_code *code)
7025 gcc_assert (code->resolved_isym);
7027 switch (code->resolved_isym->id)
7029 case GFC_ISYM_MOVE_ALLOC:
7030 res = conv_intrinsic_move_alloc (code);
7033 case GFC_ISYM_ATOMIC_DEF:
7034 res = conv_intrinsic_atomic_def (code);
7037 case GFC_ISYM_ATOMIC_REF:
7038 res = conv_intrinsic_atomic_ref (code);
7049 #include "gt-fortran-trans-intrinsic.h"