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