/* Intrinsic translation
- Copyright (C) 2002-2018 Free Software Foundation, Inc.
+ Copyright (C) 2002-2021 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#include "trans-types.h"
#include "trans-array.h"
#include "dependency.h" /* For CAF array alias analysis. */
+#include "attribs.h"
+
/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
/* This maps Fortran intrinsic math functions to external library or GCC
/* Functions in libgfortran. */
LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
+ LIB_FUNCTION (SIND, "sind", false),
+ LIB_FUNCTION (COSD, "cosd", false),
+ LIB_FUNCTION (TAND, "tand", false),
/* End the list. */
LIB_FUNCTION (NONE, NULL, false)
fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
else if (resprec <= LONG_LONG_TYPE_SIZE)
fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
+ else if (resprec >= argprec && resprec == 128)
+ {
+ /* Search for a real kind suitable as temporary for conversion. */
+ int kind = -1;
+ for (int i = 0; kind < 0 && gfc_real_kinds[i].kind != 0; i++)
+ if (gfc_real_kinds[i].mode_precision >= resprec)
+ kind = gfc_real_kinds[i].kind;
+ if (kind < 0)
+ gfc_internal_error ("Could not find real kind with at least %d bits",
+ resprec);
+ arg = fold_convert (gfc_float128_type_node, arg);
+ fn = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
+ }
else
gcc_unreachable ();
- return fold_convert (restype, build_call_expr_loc (input_location,
- fn, 1, arg));
+ return convert (restype, build_call_expr_loc (input_location,
+ fn, 1, arg));
}
return fndecl;
}
+/* Add SIMD attribute for FNDECL built-in if the built-in
+ name is in VECTORIZED_BUILTINS. */
+
+static void
+add_simd_flag_for_built_in (tree fndecl)
+{
+ if (gfc_vectorized_builtins == NULL
+ || fndecl == NULL_TREE)
+ return;
+
+ const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl));
+ int *clauses = gfc_vectorized_builtins->get (name);
+ if (clauses)
+ {
+ for (unsigned i = 0; i < 3; i++)
+ if (*clauses & (1 << i))
+ {
+ gfc_simd_clause simd_type = (gfc_simd_clause)*clauses;
+ tree omp_clause = NULL_TREE;
+ if (simd_type == SIMD_NONE)
+ ; /* No SIMD clause. */
+ else
+ {
+ omp_clause_code code
+ = (simd_type == SIMD_INBRANCH
+ ? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH);
+ omp_clause = build_omp_clause (UNKNOWN_LOCATION, code);
+ omp_clause = build_tree_list (NULL_TREE, omp_clause);
+ }
+
+ DECL_ATTRIBUTES (fndecl)
+ = tree_cons (get_identifier ("omp declare simd"), omp_clause,
+ DECL_ATTRIBUTES (fndecl));
+ }
+ }
+}
+
+ /* Set SIMD attribute to all built-in functions that are mentioned
+ in gfc_vectorized_builtins vector. */
+void
+gfc_adjust_builtins (void)
+{
+ gfc_intrinsic_map_t *m;
+ for (m = gfc_intrinsic_map;
+ m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
+ {
+ add_simd_flag_for_built_in (m->real4_decl);
+ add_simd_flag_for_built_in (m->complex4_decl);
+ add_simd_flag_for_built_in (m->real8_decl);
+ add_simd_flag_for_built_in (m->complex8_decl);
+ add_simd_flag_for_built_in (m->real10_decl);
+ add_simd_flag_for_built_in (m->complex10_decl);
+ add_simd_flag_for_built_in (m->real16_decl);
+ add_simd_flag_for_built_in (m->complex16_decl);
+ add_simd_flag_for_built_in (m->real16_decl);
+ add_simd_flag_for_built_in (m->complex16_decl);
+ }
+
+ /* Release all strings. */
+ if (gfc_vectorized_builtins != NULL)
+ {
+ for (hash_map<nofree_string_hash, int>::iterator it
+ = gfc_vectorized_builtins->begin ();
+ it != gfc_vectorized_builtins->end (); ++it)
+ free (CONST_CAST (char *, (*it).first));
+
+ delete gfc_vectorized_builtins;
+ gfc_vectorized_builtins = NULL;
+ }
+}
/* Initialize function decls for library functions. The external functions
are created as required. Builtin functions are added here. */
gcc_assert (end != NULL_TREE);
/* Multiply with the product of array's stride and
the step of the ref to a virtual upper bound.
- We can not compute the actual upper bound here or
+ We cannot compute the actual upper bound here or
the caflib would compute the extend
incorrectly. */
end = fold_build2 (MULT_EXPR, gfc_array_index_type,
}
+static void
+gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr)
+{
+ gfc_expr *arg;
+ arg = expr->value.function.actual->expr;
+ gfc_conv_is_contiguous_expr (se, arg);
+ se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
+}
+
+/* This function does the work for gfc_conv_intrinsic_is_contiguous,
+ plus it can be called directly. */
+
+void
+gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
+{
+ gfc_ss *ss;
+ gfc_se argse;
+ tree desc, tmp, stride, extent, cond;
+ int i;
+ tree fncall0;
+ gfc_array_spec *as;
+
+ if (arg->ts.type == BT_CLASS)
+ gfc_add_class_array_ref (arg);
+
+ ss = gfc_walk_expr (arg);
+ gcc_assert (ss != gfc_ss_terminator);
+ gfc_init_se (&argse, NULL);
+ argse.data_not_needed = 1;
+ gfc_conv_expr_descriptor (&argse, arg);
+
+ as = gfc_get_full_arrayspec_from_expr (arg);
+
+ /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
+ Note in addition that zero-sized arrays don't count as contiguous. */
+
+ if (as && as->type == AS_ASSUMED_RANK)
+ {
+ /* Build the call to is_contiguous0. */
+ argse.want_pointer = 1;
+ gfc_conv_expr_descriptor (&argse, arg);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+ desc = gfc_evaluate_now (argse.expr, &se->pre);
+ fncall0 = build_call_expr_loc (input_location,
+ gfor_fndecl_is_contiguous0, 1, desc);
+ se->expr = fncall0;
+ se->expr = convert (logical_type_node, se->expr);
+ }
+ else
+ {
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+ desc = gfc_evaluate_now (argse.expr, &se->pre);
+
+ stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ stride, build_int_cst (TREE_TYPE (stride), 1));
+
+ for (i = 0; i < arg->rank - 1; i++)
+ {
+ tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
+ extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
+ extent = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, extent, tmp);
+ extent = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, extent,
+ gfc_index_one_node);
+ tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]);
+ tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
+ tmp, extent);
+ stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]);
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ stride, tmp);
+ cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ boolean_type_node, cond, tmp);
+ }
+ se->expr = cond;
+ }
+}
+
+
/* Evaluate a single upper or lower bound. */
/* TODO: bound intrinsic generates way too much unnecessary code. */
se->expr = gfc_index_one_node;
}
+ /* According to F2018 16.9.172, para 5, an assumed rank object, argument
+ associated with and assumed size array, has the ubound of the final
+ dimension set to -1 and UBOUND must return this. */
+ if (upper && as && as->type == AS_ASSUMED_RANK)
+ {
+ tree minus_one = build_int_cst (gfc_array_index_type, -1);
+ tree rank = fold_convert (gfc_array_index_type,
+ gfc_conv_descriptor_rank (desc));
+ rank = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, rank, minus_one);
+ /* Fix the expression to stop it from becoming even more complicated. */
+ se->expr = gfc_evaluate_now (se->expr, &se->pre);
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, bound, rank);
+ cond1 = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, ubound, minus_one);
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ logical_type_node, cond, cond1);
+ se->expr = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ se->expr, minus_one);
+ }
+
type = gfc_typenode_for_spec (&expr->ts);
se->expr = convert (type, se->expr);
}
tree val;
tree *args;
tree type;
+ tree argtype;
gfc_actual_arglist *argexpr;
unsigned int i, nargs;
gfc_conv_intrinsic_function_args (se, expr, args, nargs);
type = gfc_typenode_for_spec (&expr->ts);
- argexpr = expr->value.function.actual;
- if (TREE_TYPE (args[0]) != type)
- args[0] = convert (type, args[0]);
/* Only evaluate the argument once. */
if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
args[0] = gfc_evaluate_now (args[0], &se->pre);
- mvar = gfc_create_var (type, "M");
- gfc_add_modify (&se->pre, mvar, args[0]);
+ /* Determine suitable type of temporary, as a GNU extension allows
+ different argument kinds. */
+ argtype = TREE_TYPE (args[0]);
+ argexpr = expr->value.function.actual;
+ for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
+ {
+ tree tmptype = TREE_TYPE (args[i]);
+ if (TYPE_PRECISION (tmptype) > TYPE_PRECISION (argtype))
+ argtype = tmptype;
+ }
+ mvar = gfc_create_var (argtype, "M");
+ gfc_add_modify (&se->pre, mvar, convert (argtype, args[0]));
+ argexpr = expr->value.function.actual;
for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
{
tree cond = NULL_TREE;
Also, there is no consensus among other tested compilers. In
short, it's a mess. So lets just do whatever is fastest. */
tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR;
- calc = fold_build2_loc (input_location, code, type,
- convert (type, val), mvar);
+ calc = fold_build2_loc (input_location, code, argtype,
+ convert (argtype, val), mvar);
tmp = build2_v (MODIFY_EXPR, mvar, calc);
if (cond != NULL_TREE)
build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->pre, tmp);
}
- se->expr = mvar;
+ if (TREE_CODE (type) == INTEGER_TYPE)
+ se->expr = fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, mvar);
+ else
+ se->expr = convert (type, mvar);
}
return sym;
}
-/* Generate a call to an external intrinsic function. */
+/* Remove empty actual arguments. */
+
+static void
+remove_empty_actual_arguments (gfc_actual_arglist **ap)
+{
+ while (*ap)
+ {
+ if ((*ap)->expr == NULL)
+ {
+ gfc_actual_arglist *r = *ap;
+ *ap = r->next;
+ r->next = NULL;
+ gfc_free_actual_arglist (r);
+ }
+ else
+ ap = &((*ap)->next);
+ }
+}
+
+#define MAX_SPEC_ARG 12
+
+/* Make up an fn spec that's right for intrinsic functions that we
+ want to call. */
+
+static char *
+intrinsic_fnspec (gfc_expr *expr)
+{
+ static char fnspec_buf[MAX_SPEC_ARG*2+1];
+ char *fp;
+ int i;
+ int num_char_args;
+
+#define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
+
+ /* Set the fndecl. */
+ fp = fnspec_buf;
+ /* Function return value. FIXME: Check if the second letter could
+ be something other than a space, for further optimization. */
+ ADD_CHAR ('.');
+ if (expr->rank == 0)
+ {
+ if (expr->ts.type == BT_CHARACTER)
+ {
+ ADD_CHAR ('w'); /* Address of character. */
+ ADD_CHAR ('.'); /* Length of character. */
+ }
+ }
+ else
+ ADD_CHAR ('w'); /* Return value is a descriptor. */
+
+ num_char_args = 0;
+ for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
+ {
+ if (a->expr == NULL)
+ continue;
+
+ if (a->name && strcmp (a->name,"%VAL") == 0)
+ ADD_CHAR ('.');
+ else
+ {
+ if (a->expr->rank > 0)
+ ADD_CHAR ('r');
+ else
+ ADD_CHAR ('R');
+ }
+ num_char_args += a->expr->ts.type == BT_CHARACTER;
+ gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2);
+ }
+
+ for (i = 0; i < num_char_args; i++)
+ ADD_CHAR ('.');
+
+ *fp = '\0';
+ return fnspec_buf;
+}
+
+#undef MAX_SPEC_ARG
+#undef ADD_CHAR
+
+/* Generate the right symbol for the specific intrinsic function and
+ modify the expr accordingly. This assumes that absent optional
+ arguments should be removed. */
+
+gfc_symbol *
+specific_intrinsic_symbol (gfc_expr *expr)
+{
+ gfc_symbol *sym;
+
+ sym = gfc_find_intrinsic_symbol (expr);
+ if (sym == NULL)
+ {
+ sym = gfc_get_intrinsic_function_symbol (expr);
+ sym->ts = expr->ts;
+ if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl)
+ sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
+
+ gfc_copy_formal_args_intr (sym, expr->value.function.isym,
+ expr->value.function.actual, true);
+ sym->backend_decl
+ = gfc_get_extern_function_decl (sym, expr->value.function.actual,
+ intrinsic_fnspec (expr));
+ }
+
+ remove_empty_actual_arguments (&(expr->value.function.actual));
+
+ return sym;
+}
+
+/* Generate a call to an external intrinsic function. FIXME: So far,
+ this only works for functions which are called with well-defined
+ types; CSHIFT and friends will come later. */
+
static void
gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
{
gfc_symbol *sym;
vec<tree, va_gc> *append_args;
+ bool specific_symbol;
gcc_assert (!se->ss || se->ss->info->expr == expr);
else
gcc_assert (expr->rank == 0);
- sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
+ switch (expr->value.function.isym->id)
+ {
+ case GFC_ISYM_ANY:
+ case GFC_ISYM_ALL:
+ case GFC_ISYM_FINDLOC:
+ case GFC_ISYM_MAXLOC:
+ case GFC_ISYM_MINLOC:
+ case GFC_ISYM_MAXVAL:
+ case GFC_ISYM_MINVAL:
+ case GFC_ISYM_NORM2:
+ case GFC_ISYM_PRODUCT:
+ case GFC_ISYM_SUM:
+ specific_symbol = true;
+ break;
+ default:
+ specific_symbol = false;
+ }
+
+ if (specific_symbol)
+ {
+ /* Need to copy here because specific_intrinsic_symbol modifies
+ expr to omit the absent optional arguments. */
+ expr = gfc_copy_expr (expr);
+ sym = specific_intrinsic_symbol (expr);
+ }
+ else
+ sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
/* Calls to libgfortran_matmul need to be appended special arguments,
to be able to call the BLAS ?gemm functions if required and possible. */
gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
append_args);
- gfc_free_symbol (sym);
+
+ if (specific_symbol)
+ gfc_free_expr (expr);
+ else
+ gfc_free_symbol (sym);
}
/* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
se->expr = resvar;
}
+
+/* Generate the constant 180 / pi, which is used in the conversion
+ of acosd(), asind(), atand(), atan2d(). */
+
+static tree
+rad2deg (int kind)
+{
+ tree retval;
+ mpfr_t pi, t0;
+
+ gfc_set_model_kind (kind);
+ mpfr_init (pi);
+ mpfr_init (t0);
+ mpfr_set_si (t0, 180, GFC_RND_MODE);
+ mpfr_const_pi (pi, GFC_RND_MODE);
+ mpfr_div (t0, t0, pi, GFC_RND_MODE);
+ retval = gfc_conv_mpfr_to_tree (t0, kind, 0);
+ mpfr_clear (t0);
+ mpfr_clear (pi);
+ return retval;
+}
+
+
+/* ACOSD(x) is translated into ACOS(x) * 180 / pi.
+ ASIND(x) is translated into ASIN(x) * 180 / pi.
+ ATAND(x) is translated into ATAN(x) * 180 / pi. */
+
+static void
+gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id)
+{
+ tree arg;
+ tree atrigd;
+ tree type;
+
+ type = gfc_typenode_for_spec (&expr->ts);
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+
+ if (id == GFC_ISYM_ACOSD)
+ atrigd = gfc_builtin_decl_for_float_kind (BUILT_IN_ACOS, expr->ts.kind);
+ else if (id == GFC_ISYM_ASIND)
+ atrigd = gfc_builtin_decl_for_float_kind (BUILT_IN_ASIN, expr->ts.kind);
+ else if (id == GFC_ISYM_ATAND)
+ atrigd = gfc_builtin_decl_for_float_kind (BUILT_IN_ATAN, expr->ts.kind);
+ else
+ gcc_unreachable ();
+
+ atrigd = build_call_expr_loc (input_location, atrigd, 1, arg);
+
+ se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd,
+ fold_convert (type, rad2deg (expr->ts.kind)));
+}
+
+
+/* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
+ COS(X) / SIN(X) for COMPLEX argument. */
+
+static void
+gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
+{
+ gfc_intrinsic_map_t *m;
+ tree arg;
+ tree type;
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+
+ if (expr->ts.type == BT_REAL)
+ {
+ tree tan;
+ tree tmp;
+ mpfr_t pio2;
+
+ /* Create pi/2. */
+ gfc_set_model_kind (expr->ts.kind);
+ mpfr_init (pio2);
+ mpfr_const_pi (pio2, GFC_RND_MODE);
+ mpfr_div_ui (pio2, pio2, 2, GFC_RND_MODE);
+ tmp = gfc_conv_mpfr_to_tree (pio2, expr->ts.kind, 0);
+ mpfr_clear (pio2);
+
+ /* Find tan builtin function. */
+ m = gfc_intrinsic_map;
+ for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
+ if (GFC_ISYM_TAN == m->id)
+ break;
+
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp);
+ tan = gfc_get_intrinsic_lib_fndecl (m, expr);
+ tan = build_call_expr_loc (input_location, tan, 1, tmp);
+ se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan);
+ }
+ else
+ {
+ tree sin;
+ tree cos;
+
+ /* Find cos builtin function. */
+ m = gfc_intrinsic_map;
+ for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
+ if (GFC_ISYM_COS == m->id)
+ break;
+
+ cos = gfc_get_intrinsic_lib_fndecl (m, expr);
+ cos = build_call_expr_loc (input_location, cos, 1, arg);
+
+ /* Find sin builtin function. */
+ m = gfc_intrinsic_map;
+ for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
+ if (GFC_ISYM_SIN == m->id)
+ break;
+
+ sin = gfc_get_intrinsic_lib_fndecl (m, expr);
+ sin = build_call_expr_loc (input_location, sin, 1, arg);
+
+ /* Divide cos by sin. */
+ se->expr = fold_build2_loc (input_location, RDIV_EXPR, type, cos, sin);
+ }
+}
+
+
+/* COTAND(X) is translated into -TAND(X+90) for REAL argument. */
+
+static void
+gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr)
+{
+ tree arg;
+ tree type;
+ tree ninety_tree;
+ mpfr_t ninety;
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+
+ gfc_set_model_kind (expr->ts.kind);
+
+ /* Build the tree for x + 90. */
+ mpfr_init_set_ui (ninety, 90, GFC_RND_MODE);
+ ninety_tree = gfc_conv_mpfr_to_tree (ninety, expr->ts.kind, 0);
+ arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, ninety_tree);
+ mpfr_clear (ninety);
+
+ /* Find tand. */
+ gfc_intrinsic_map_t *m = gfc_intrinsic_map;
+ for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
+ if (GFC_ISYM_TAND == m->id)
+ break;
+
+ tree tand = gfc_get_intrinsic_lib_fndecl (m, expr);
+ tand = build_call_expr_loc (input_location, tand, 1, arg);
+
+ se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tand);
+}
+
+
+/* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
+
+static void
+gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr)
+{
+ tree args[2];
+ tree atan2d;
+ tree type;
+
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ type = TREE_TYPE (args[0]);
+
+ atan2d = gfc_builtin_decl_for_float_kind (BUILT_IN_ATAN2, expr->ts.kind);
+ atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]);
+
+ se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d,
+ rad2deg (expr->ts.kind));
+}
+
+
/* COUNT(A) = Number of true elements in A. */
static void
gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
return se->ss->loop;
}
+/* Build the condition for a mask, which may be optional. */
+
+static tree
+conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr,
+ bool optional_mask)
+{
+ tree present;
+ tree type;
+
+ if (optional_mask)
+ {
+ type = TREE_TYPE (maskse->expr);
+ present = gfc_conv_expr_present (maskexpr->symtree->n.sym);
+ present = convert (type, present);
+ present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type,
+ present);
+ return fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ type, present, maskse->expr);
+ }
+ else
+ return maskse->expr;
+}
/* Inline implementation of the sum and product intrinsics. */
static void
gfc_se *parent_se;
gfc_expr *arrayexpr;
gfc_expr *maskexpr;
+ bool optional_mask;
if (expr->rank > 0)
{
arrayexpr = arg_array->expr;
if (op == NE_EXPR || norm2)
- /* PARITY and NORM2. */
- maskexpr = NULL;
+ {
+ /* PARITY and NORM2. */
+ maskexpr = NULL;
+ optional_mask = false;
+ }
else
{
arg_mask = arg_array->next->next;
gcc_assert (arg_mask != NULL);
maskexpr = arg_mask->expr;
+ optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
+ && maskexpr->symtree->n.sym->attr.dummy
+ && maskexpr->symtree->n.sym->attr.optional;
}
if (expr->rank == 0)
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
- gfc_add_ss_to_loop (&loop, arrayss);
+
+ /* We add the mask first because the number of iterations is
+ taken from the last ss, and this breaks if an absent
+ optional argument is used for mask. */
+
if (maskexpr && maskexpr->rank > 0)
gfc_add_ss_to_loop (&loop, maskss);
+ gfc_add_ss_to_loop (&loop, arrayss);
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop, &expr->where);
- gfc_mark_ss_chain_used (arrayss, 1);
if (maskexpr && maskexpr->rank > 0)
gfc_mark_ss_chain_used (maskss, 1);
+ gfc_mark_ss_chain_used (arrayss, 1);
ploop = &loop;
}
if (maskexpr && maskexpr->rank > 0)
{
- /* We enclose the above in if (mask) {...} . */
-
+ /* We enclose the above in if (mask) {...} . If the mask is an
+ optional argument, generate
+ IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
+ tree ifmask;
tmp = gfc_finish_block (&block);
- tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+ ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
+ tmp = build3_v (COND_EXPR, ifmask, tmp,
build_empty_stmt (input_location));
}
else
}
else
{
+ tree ifmask;
+
gcc_assert (expr->rank == 0);
gfc_init_se (&maskse, NULL);
gfc_conv_expr_val (&maskse, maskexpr);
- tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+ ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
+ tmp = build3_v (COND_EXPR, ifmask, tmp,
build_empty_stmt (input_location));
}
}
+/* Remove unneeded kind= argument from actual argument list when the
+ result conversion is dealt with in a different place. */
+
+static void
+strip_kind_from_actual (gfc_actual_arglist * actual)
+{
+ for (gfc_actual_arglist *a = actual; a; a = a->next)
+ {
+ if (a && a->name && strcmp (a->name, "kind") == 0)
+ {
+ gfc_free_expr (a->expr);
+ a->expr = NULL;
+ }
+ }
+}
+
/* Emit code for minloc or maxloc intrinsic. There are many different cases
we need to handle. For performance reasons we sometimes create two
loops instead of one, where the second one is much simpler.
gfc_se backse;
tree pos;
int n;
+ bool optional_mask;
actual = expr->value.function.actual;
if (arrayexpr->ts.type == BT_CHARACTER)
{
- gfc_actual_arglist *a, *b;
+ gfc_actual_arglist *a;
a = actual;
- while (a->next)
+ strip_kind_from_actual (a);
+ while (a)
{
- b = a->next;
- if (b->expr == NULL || strcmp (b->name, "dim") == 0)
+ if (a->name && strcmp (a->name, "dim") == 0)
{
- a->next = b->next;
- b->next = NULL;
- gfc_free_actual_arglist (b);
+ gfc_free_expr (a->expr);
+ a->expr = NULL;
}
- else
- a = b;
+ a = a->next;
}
gfc_conv_intrinsic_funcall (se, expr);
return;
actual = actual->next->next;
gcc_assert (actual);
maskexpr = actual->expr;
+ optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
+ && maskexpr->symtree->n.sym->attr.dummy
+ && maskexpr->symtree->n.sym->attr.optional;
backexpr = actual->next->next->expr;
nonempty = NULL;
if (maskexpr && maskexpr->rank != 0)
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
- gfc_add_ss_to_loop (&loop, arrayss);
+
+ /* We add the mask first because the number of iterations is taken
+ from the last ss, and this breaks if an absent optional argument
+ is used for mask. */
+
if (maskss)
gfc_add_ss_to_loop (&loop, maskss);
+ gfc_add_ss_to_loop (&loop, arrayss);
+
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
if (maskss)
{
- /* We enclose the above in if (mask) {...}. */
- tmp = gfc_finish_block (&block);
+ /* We enclose the above in if (mask) {...}. If the mask is an
+ optional argument, generate IF (.NOT. PRESENT(MASK)
+ .OR. MASK(I)). */
- tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+ tree ifmask;
+ ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
+ tmp = gfc_finish_block (&block);
+ tmp = build3_v (COND_EXPR, ifmask, tmp,
build_empty_stmt (input_location));
}
else
tmp = gfc_finish_block (&block);
gfc_add_expr_to_block (&body, tmp);
- if (lab1)
- {
- gfc_trans_scalarized_loop_boundary (&loop, &body);
+ if (lab1)
+ {
+ gfc_trans_scalarized_loop_boundary (&loop, &body);
+
+ if (HONOR_NANS (DECL_MODE (limit)))
+ {
+ if (nonempty != NULL)
+ {
+ ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
+ tmp = build3_v (COND_EXPR, nonempty, ifbody,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&loop.code[0], tmp);
+ }
+ }
+
+ gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
+ gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
+
+ /* If we have a mask, only check this element if the mask is set. */
+ if (maskss)
+ {
+ gfc_init_se (&maskse, NULL);
+ gfc_copy_loopinfo_to_se (&maskse, &loop);
+ maskse.ss = maskss;
+ gfc_conv_expr_val (&maskse, maskexpr);
+ gfc_add_block_to_block (&body, &maskse.pre);
+
+ gfc_start_block (&block);
+ }
+ else
+ gfc_init_block (&block);
+
+ /* Compare with the current limit. */
+ gfc_init_se (&arrayse, NULL);
+ gfc_copy_loopinfo_to_se (&arrayse, &loop);
+ arrayse.ss = arrayss;
+ gfc_conv_expr_val (&arrayse, arrayexpr);
+ gfc_add_block_to_block (&block, &arrayse.pre);
+
+ /* We do the following if this is a more extreme value. */
+ gfc_start_block (&ifblock);
+
+ /* Assign the value to the limit... */
+ gfc_add_modify (&ifblock, limit, arrayse.expr);
+
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
+ loop.loopvar[0], offset);
+ gfc_add_modify (&ifblock, pos, tmp);
+
+ ifbody = gfc_finish_block (&ifblock);
+
+ /* We switch to > or >= depending on the value of the BACK argument. */
+ {
+ tree ifbody2, elsebody2;
+
+ cond = gfc_create_var (logical_type_node, "cond");
+
+ gfc_start_block (&ifblock);
+ b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
+ logical_type_node, arrayse.expr, limit);
+
+ gfc_add_modify (&ifblock, cond, b_if);
+ ifbody2 = gfc_finish_block (&ifblock);
+
+ gfc_start_block (&elseblock);
+ b_else = fold_build2_loc (input_location, op, logical_type_node,
+ arrayse.expr, limit);
+
+ gfc_add_modify (&elseblock, cond, b_else);
+ elsebody2 = gfc_finish_block (&elseblock);
+
+ tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
+ backse.expr, ifbody2, elsebody2);
+ }
+
+ gfc_add_expr_to_block (&block, tmp);
+ cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
+ tmp = build3_v (COND_EXPR, cond, ifbody,
+ build_empty_stmt (input_location));
+
+ gfc_add_expr_to_block (&block, tmp);
+
+ if (maskss)
+ {
+ /* We enclose the above in if (mask) {...}. If the mask is
+ an optional argument, generate IF (.NOT. PRESENT(MASK)
+ .OR. MASK(I)).*/
+
+ tree ifmask;
+ ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
+ tmp = gfc_finish_block (&block);
+ tmp = build3_v (COND_EXPR, ifmask, tmp,
+ build_empty_stmt (input_location));
+ }
+ else
+ tmp = gfc_finish_block (&block);
+ gfc_add_expr_to_block (&body, tmp);
+ /* Avoid initializing loopvar[0] again, it should be left where
+ it finished by the first loop. */
+ loop.from[0] = loop.loopvar[0];
+ }
+
+ gfc_trans_scalarizing_loops (&loop, &body);
+
+ if (lab2)
+ gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
+
+ /* For a scalar mask, enclose the loop in an if statement. */
+ if (maskexpr && maskss == NULL)
+ {
+ tree ifmask;
+
+ gfc_init_se (&maskse, NULL);
+ gfc_conv_expr_val (&maskse, maskexpr);
+ gfc_init_block (&block);
+ gfc_add_block_to_block (&block, &loop.pre);
+ gfc_add_block_to_block (&block, &loop.post);
+ tmp = gfc_finish_block (&block);
+
+ /* For the else part of the scalar mask, just initialize
+ the pos variable the same way as above. */
+
+ gfc_init_block (&elseblock);
+ gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
+ elsetmp = gfc_finish_block (&elseblock);
+ ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
+ tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp);
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_add_block_to_block (&se->pre, &block);
+ }
+ else
+ {
+ gfc_add_block_to_block (&se->pre, &loop.pre);
+ gfc_add_block_to_block (&se->pre, &loop.post);
+ }
+ gfc_cleanup_loop (&loop);
+
+ se->expr = convert (type, pos);
+}
+
+/* Emit code for findloc. */
+
+static void
+gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
+{
+ gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg,
+ *kind_arg, *back_arg;
+ gfc_expr *value_expr;
+ int ikind;
+ tree resvar;
+ stmtblock_t block;
+ stmtblock_t body;
+ stmtblock_t loopblock;
+ tree type;
+ tree tmp;
+ tree found;
+ tree forward_branch = NULL_TREE;
+ tree back_branch;
+ gfc_loopinfo loop;
+ gfc_ss *arrayss;
+ gfc_ss *maskss;
+ gfc_se arrayse;
+ gfc_se valuese;
+ gfc_se maskse;
+ gfc_se backse;
+ tree exit_label;
+ gfc_expr *maskexpr;
+ tree offset;
+ int i;
+ bool optional_mask;
+
+ array_arg = expr->value.function.actual;
+ value_arg = array_arg->next;
+ dim_arg = value_arg->next;
+ mask_arg = dim_arg->next;
+ kind_arg = mask_arg->next;
+ back_arg = kind_arg->next;
+
+ /* Remove kind and set ikind. */
+ if (kind_arg->expr)
+ {
+ ikind = mpz_get_si (kind_arg->expr->value.integer);
+ gfc_free_expr (kind_arg->expr);
+ kind_arg->expr = NULL;
+ }
+ else
+ ikind = gfc_default_integer_kind;
+
+ value_expr = value_arg->expr;
+
+ /* Unless it's a string, pass VALUE by value. */
+ if (value_expr->ts.type != BT_CHARACTER)
+ value_arg->name = "%VAL";
+
+ /* Pass BACK argument by value. */
+ back_arg->name = "%VAL";
+
+ /* Call the library if we have a character function or if
+ rank > 0. */
+ if (se->ss || array_arg->expr->ts.type == BT_CHARACTER)
+ {
+ se->ignore_optional = 1;
+ if (expr->rank == 0)
+ {
+ /* Remove dim argument. */
+ gfc_free_expr (dim_arg->expr);
+ dim_arg->expr = NULL;
+ }
+ gfc_conv_intrinsic_funcall (se, expr);
+ return;
+ }
+
+ type = gfc_get_int_type (ikind);
+
+ /* Initialize the result. */
+ resvar = gfc_create_var (gfc_array_index_type, "pos");
+ gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0));
+ offset = gfc_create_var (gfc_array_index_type, "offset");
+
+ maskexpr = mask_arg->expr;
+ optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
+ && maskexpr->symtree->n.sym->attr.dummy
+ && maskexpr->symtree->n.sym->attr.optional;
+
+ /* Generate two loops, one for BACK=.true. and one for BACK=.false. */
+
+ for (i = 0 ; i < 2; i++)
+ {
+ /* Walk the arguments. */
+ arrayss = gfc_walk_expr (array_arg->expr);
+ gcc_assert (arrayss != gfc_ss_terminator);
+
+ if (maskexpr && maskexpr->rank != 0)
+ {
+ maskss = gfc_walk_expr (maskexpr);
+ gcc_assert (maskss != gfc_ss_terminator);
+ }
+ else
+ maskss = NULL;
+
+ /* Initialize the scalarizer. */
+ gfc_init_loopinfo (&loop);
+ exit_label = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (exit_label) = 1;
+
+ /* We add the mask first because the number of iterations is
+ taken from the last ss, and this breaks if an absent
+ optional argument is used for mask. */
+
+ if (maskss)
+ gfc_add_ss_to_loop (&loop, maskss);
+ gfc_add_ss_to_loop (&loop, arrayss);
+
+ /* Initialize the loop. */
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop, &expr->where);
+
+ /* Calculate the offset. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, loop.from[0]);
+ gfc_add_modify (&loop.pre, offset, tmp);
- if (HONOR_NANS (DECL_MODE (limit)))
- {
- if (nonempty != NULL)
- {
- ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
- tmp = build3_v (COND_EXPR, nonempty, ifbody,
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&loop.code[0], tmp);
- }
- }
+ gfc_mark_ss_chain_used (arrayss, 1);
+ if (maskss)
+ gfc_mark_ss_chain_used (maskss, 1);
- gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
- gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
+ /* The first loop is for BACK=.true. */
+ if (i == 0)
+ loop.reverse[0] = GFC_REVERSE_SET;
- /* If we have a mask, only check this element if the mask is set. */
+ /* Generate the loop body. */
+ gfc_start_scalarized_body (&loop, &body);
+
+ /* If we have an array mask, only add the element if it is
+ set. */
if (maskss)
{
gfc_init_se (&maskse, NULL);
maskse.ss = maskss;
gfc_conv_expr_val (&maskse, maskexpr);
gfc_add_block_to_block (&body, &maskse.pre);
-
- gfc_start_block (&block);
}
- else
- gfc_init_block (&block);
-
- /* Compare with the current limit. */
- gfc_init_se (&arrayse, NULL);
- gfc_copy_loopinfo_to_se (&arrayse, &loop);
- arrayse.ss = arrayss;
- gfc_conv_expr_val (&arrayse, arrayexpr);
- gfc_add_block_to_block (&block, &arrayse.pre);
-
- /* We do the following if this is a more extreme value. */
- gfc_start_block (&ifblock);
- /* Assign the value to the limit... */
- gfc_add_modify (&ifblock, limit, arrayse.expr);
+ /* If the condition matches then set the return value. */
+ gfc_start_block (&block);
- tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
+ /* Add the offset. */
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ TREE_TYPE (resvar),
loop.loopvar[0], offset);
- gfc_add_modify (&ifblock, pos, tmp);
-
- ifbody = gfc_finish_block (&ifblock);
-
- /* We switch to > or >= depending on the value of the BACK argument. */
- {
- tree ifbody2, elsebody2;
-
- cond = gfc_create_var (logical_type_node, "cond");
-
- gfc_start_block (&ifblock);
- b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
- logical_type_node, arrayse.expr, limit);
-
- gfc_add_modify (&ifblock, cond, b_if);
- ifbody2 = gfc_finish_block (&ifblock);
-
- gfc_start_block (&elseblock);
- b_else = fold_build2_loc (input_location, op, logical_type_node,
- arrayse.expr, limit);
+ gfc_add_modify (&block, resvar, tmp);
+ /* And break out of the loop. */
+ tmp = build1_v (GOTO_EXPR, exit_label);
+ gfc_add_expr_to_block (&block, tmp);
- gfc_add_modify (&elseblock, cond, b_else);
- elsebody2 = gfc_finish_block (&elseblock);
+ found = gfc_finish_block (&block);
- tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
- backse.expr, ifbody2, elsebody2);
- }
+ /* Check this element. */
+ gfc_init_se (&arrayse, NULL);
+ gfc_copy_loopinfo_to_se (&arrayse, &loop);
+ arrayse.ss = arrayss;
+ gfc_conv_expr_val (&arrayse, array_arg->expr);
+ gfc_add_block_to_block (&body, &arrayse.pre);
- gfc_add_expr_to_block (&block, tmp);
- cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
- tmp = build3_v (COND_EXPR, cond, ifbody,
- build_empty_stmt (input_location));
+ gfc_init_se (&valuese, NULL);
+ gfc_conv_expr_val (&valuese, value_arg->expr);
+ gfc_add_block_to_block (&body, &valuese.pre);
- gfc_add_expr_to_block (&block, tmp);
+ tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
+ arrayse.expr, valuese.expr);
+ tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
if (maskss)
{
- /* We enclose the above in if (mask) {...}. */
- tmp = gfc_finish_block (&block);
+ /* We enclose the above in if (mask) {...}. If the mask is
+ an optional argument, generate IF (.NOT. PRESENT(MASK)
+ .OR. MASK(I)). */
- tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+ tree ifmask;
+ ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
+ tmp = build3_v (COND_EXPR, ifmask, tmp,
build_empty_stmt (input_location));
}
- else
- tmp = gfc_finish_block (&block);
+
gfc_add_expr_to_block (&body, tmp);
- /* Avoid initializing loopvar[0] again, it should be left where
- it finished by the first loop. */
- loop.from[0] = loop.loopvar[0];
+ gfc_add_block_to_block (&body, &arrayse.post);
+
+ gfc_trans_scalarizing_loops (&loop, &body);
+
+ /* Add the exit label. */
+ tmp = build1_v (LABEL_EXPR, exit_label);
+ gfc_add_expr_to_block (&loop.pre, tmp);
+ gfc_start_block (&loopblock);
+ gfc_add_block_to_block (&loopblock, &loop.pre);
+ gfc_add_block_to_block (&loopblock, &loop.post);
+ if (i == 0)
+ forward_branch = gfc_finish_block (&loopblock);
+ else
+ back_branch = gfc_finish_block (&loopblock);
+
+ gfc_cleanup_loop (&loop);
}
- gfc_trans_scalarizing_loops (&loop, &body);
+ /* Enclose the two loops in an IF statement. */
- if (lab2)
- gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
+ gfc_init_se (&backse, NULL);
+ gfc_conv_expr_val (&backse, back_arg->expr);
+ gfc_add_block_to_block (&se->pre, &backse.pre);
+ tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch);
/* For a scalar mask, enclose the loop in an if statement. */
if (maskexpr && maskss == NULL)
{
+ tree ifmask;
+ tree if_stmt;
+
gfc_init_se (&maskse, NULL);
gfc_conv_expr_val (&maskse, maskexpr);
gfc_init_block (&block);
- gfc_add_block_to_block (&block, &loop.pre);
- gfc_add_block_to_block (&block, &loop.post);
+ gfc_add_expr_to_block (&block, maskse.expr);
+ ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
+ if_stmt = build3_v (COND_EXPR, ifmask, tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, if_stmt);
tmp = gfc_finish_block (&block);
-
- /* For the else part of the scalar mask, just initialize
- the pos variable the same way as above. */
-
- gfc_init_block (&elseblock);
- gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
- elsetmp = gfc_finish_block (&elseblock);
-
- tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
- gfc_add_expr_to_block (&block, tmp);
- gfc_add_block_to_block (&se->pre, &block);
- }
- else
- {
- gfc_add_block_to_block (&se->pre, &loop.pre);
- gfc_add_block_to_block (&se->pre, &loop.post);
}
- gfc_cleanup_loop (&loop);
- se->expr = convert (type, pos);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ se->expr = convert (type, resvar);
+
}
/* Emit code for minval or maxval intrinsic. There are many different cases
gfc_expr *arrayexpr;
gfc_expr *maskexpr;
int n;
+ bool optional_mask;
if (se->ss)
{
if (arrayexpr->ts.type == BT_CHARACTER)
{
- gfc_actual_arglist *a2, *a3;
- a2 = actual->next; /* dim */
- a3 = a2->next; /* mask */
- if (a2->expr == NULL || expr->rank == 0)
+ gfc_actual_arglist *dim = actual->next;
+ if (expr->rank == 0 && dim->expr != 0)
{
- if (a3->expr == NULL)
- actual->next = NULL;
- else
- {
- actual->next = a3;
- a2->next = NULL;
- }
- gfc_free_actual_arglist (a2);
+ gfc_free_expr (dim->expr);
+ dim->expr = NULL;
}
- else
- if (a3->expr == NULL)
- {
- a2->next = NULL;
- gfc_free_actual_arglist (a3);
- }
gfc_conv_intrinsic_funcall (se, expr);
return;
}
+
type = gfc_typenode_for_spec (&expr->ts);
/* Initialize the result. */
limit = gfc_create_var (type, "limit");
actual = actual->next->next;
gcc_assert (actual);
maskexpr = actual->expr;
+ optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
+ && maskexpr->symtree->n.sym->attr.dummy
+ && maskexpr->symtree->n.sym->attr.optional;
nonempty = NULL;
if (maskexpr && maskexpr->rank != 0)
{
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
- gfc_add_ss_to_loop (&loop, arrayss);
+
+ /* We add the mask first because the number of iterations is taken
+ from the last ss, and this breaks if an absent optional argument
+ is used for mask. */
+
if (maskss)
gfc_add_ss_to_loop (&loop, maskss);
+ gfc_add_ss_to_loop (&loop, arrayss);
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
tmp = gfc_finish_block (&block);
if (maskss)
- /* We enclose the above in if (mask) {...}. */
- tmp = build3_v (COND_EXPR, maskse.expr, tmp,
- build_empty_stmt (input_location));
+ {
+ /* We enclose the above in if (mask) {...}. If the mask is an
+ optional argument, generate IF (.NOT. PRESENT(MASK)
+ .OR. MASK(I)). */
+ tree ifmask;
+ ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
+ tmp = build3_v (COND_EXPR, ifmask, tmp,
+ build_empty_stmt (input_location));
+ }
gfc_add_expr_to_block (&body, tmp);
if (lab)
tmp = gfc_finish_block (&block);
if (maskss)
/* We enclose the above in if (mask) {...}. */
- tmp = build3_v (COND_EXPR, maskse.expr, tmp,
- build_empty_stmt (input_location));
+ {
+ tree ifmask;
+ ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
+ tmp = build3_v (COND_EXPR, ifmask, tmp,
+ build_empty_stmt (input_location));
+ }
+
gfc_add_expr_to_block (&body, tmp);
/* Avoid initializing loopvar[0] again, it should be left where
it finished by the first loop. */
if (maskexpr && maskss == NULL)
{
tree else_stmt;
+ tree ifmask;
gfc_init_se (&maskse, NULL);
gfc_conv_expr_val (&maskse, maskexpr);
else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
else
else_stmt = build_empty_stmt (input_location);
- tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
+
+ ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
+ tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&se->pre, &block);
}
gfc_conv_intrinsic_function_args (se, expr, args, 2);
type = TREE_TYPE (args[0]);
+ /* Optionally generate code for runtime argument check. */
+ if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
+ {
+ tree below = fold_build2_loc (input_location, LT_EXPR,
+ logical_type_node, args[1],
+ build_int_cst (TREE_TYPE (args[1]), 0));
+ tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
+ tree above = fold_build2_loc (input_location, GE_EXPR,
+ logical_type_node, args[1], nbits);
+ tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ logical_type_node, below, above);
+ gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
+ "POS argument (%ld) out of range 0:%ld "
+ "in intrinsic BTEST",
+ fold_convert (long_integer_type_node, args[1]),
+ fold_convert (long_integer_type_node, nbits));
+ }
+
tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
build_int_cst (type, 1), args[1]);
tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
gfc_conv_intrinsic_function_args (se, expr, args, 2);
type = TREE_TYPE (args[0]);
+ /* Optionally generate code for runtime argument check. */
+ if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
+ {
+ tree below = fold_build2_loc (input_location, LT_EXPR,
+ logical_type_node, args[1],
+ build_int_cst (TREE_TYPE (args[1]), 0));
+ tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
+ tree above = fold_build2_loc (input_location, GE_EXPR,
+ logical_type_node, args[1], nbits);
+ tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ logical_type_node, below, above);
+ size_t len_name = strlen (expr->value.function.isym->name);
+ char *name = XALLOCAVEC (char, len_name + 1);
+ for (size_t i = 0; i < len_name; i++)
+ name[i] = TOUPPER (expr->value.function.isym->name[i]);
+ name[len_name] = '\0';
+ tree iname = gfc_build_addr_expr (pchar_type_node,
+ gfc_build_cstring_const (name));
+ gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
+ "POS argument (%ld) out of range 0:%ld "
+ "in intrinsic %s",
+ fold_convert (long_integer_type_node, args[1]),
+ fold_convert (long_integer_type_node, nbits),
+ iname);
+ }
+
tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
build_int_cst (type, 1), args[1]);
if (set)
gfc_conv_intrinsic_function_args (se, expr, args, 3);
type = TREE_TYPE (args[0]);
+ /* Optionally generate code for runtime argument check. */
+ if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
+ {
+ tree tmp1 = fold_convert (long_integer_type_node, args[1]);
+ tree tmp2 = fold_convert (long_integer_type_node, args[2]);
+ tree nbits = build_int_cst (long_integer_type_node,
+ TYPE_PRECISION (type));
+ tree below = fold_build2_loc (input_location, LT_EXPR,
+ logical_type_node, args[1],
+ build_int_cst (TREE_TYPE (args[1]), 0));
+ tree above = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, tmp1, nbits);
+ tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ logical_type_node, below, above);
+ gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
+ "POS argument (%ld) out of range 0:%ld "
+ "in intrinsic IBITS", tmp1, nbits);
+ below = fold_build2_loc (input_location, LT_EXPR,
+ logical_type_node, args[2],
+ build_int_cst (TREE_TYPE (args[2]), 0));
+ above = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, tmp2, nbits);
+ scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ logical_type_node, below, above);
+ gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
+ "LEN argument (%ld) out of range 0:%ld "
+ "in intrinsic IBITS", tmp2, nbits);
+ above = fold_build2_loc (input_location, PLUS_EXPR,
+ long_integer_type_node, tmp1, tmp2);
+ scond = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, above, nbits);
+ gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
+ "POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) "
+ "in intrinsic IBITS", tmp1, tmp2, nbits);
+ }
+
mask = build_int_cst (type, -1);
mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
{
gfc_actual_arglist *s, *k;
gfc_expr *e;
+ gfc_array_spec *as;
+ gfc_ss *ss;
/* Remove the KIND argument, if present. */
s = expr->value.function.actual;
k->expr = NULL;
gfc_conv_intrinsic_funcall (se, expr);
+
+ as = gfc_get_full_arrayspec_from_expr (s->expr);;
+ ss = gfc_walk_expr (s->expr);
+
+ /* According to F2018 16.9.172, para 5, an assumed rank entity, argument
+ associated with an assumed size array, has the ubound of the final
+ dimension set to -1 and SHAPE must return this. */
+ if (as && as->type == AS_ASSUMED_RANK
+ && se->expr && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))
+ && ss && ss->info->type == GFC_SS_SECTION)
+ {
+ tree desc, rank, minus_one, cond, ubound, tmp;
+ stmtblock_t block;
+ gfc_se ase;
+
+ minus_one = build_int_cst (gfc_array_index_type, -1);
+
+ /* Recover the descriptor for the array. */
+ gfc_init_se (&ase, NULL);
+ ase.descriptor_only = 1;
+ gfc_conv_expr_lhs (&ase, ss->info->expr);
+
+ /* Obtain rank-1 so that we can address both descriptors. */
+ rank = gfc_conv_descriptor_rank (ase.expr);
+ rank = fold_convert (gfc_array_index_type, rank);
+ rank = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ rank, minus_one);
+ rank = gfc_evaluate_now (rank, &se->pre);
+
+ /* The ubound for the final dimension will be tested for being -1. */
+ ubound = gfc_conv_descriptor_ubound_get (ase.expr, rank);
+ ubound = gfc_evaluate_now (ubound, &se->pre);
+ cond = fold_build2_loc (input_location, EQ_EXPR,
+ logical_type_node,
+ ubound, minus_one);
+
+ /* Obtain the last element of the result from the library shape
+ intrinsic and set it to -1 if that is the value of ubound. */
+ desc = se->expr;
+ tmp = gfc_conv_array_data (desc);
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ tmp = gfc_build_array_ref (tmp, rank, NULL, NULL);
+
+ gfc_init_block (&block);
+ gfc_add_modify (&block, tmp, build_int_cst (TREE_TYPE (tmp), -1));
+
+ cond = build3_v (COND_EXPR, cond,
+ gfc_finish_block (&block),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->pre, cond);
+ }
+
}
static void
bool arithmetic)
{
tree args[2], type, num_bits, cond;
+ tree bigshift;
gfc_conv_intrinsic_function_args (se, expr, args, 2);
if (!arithmetic)
se->expr = fold_convert (type, se->expr);
+ if (!arithmetic)
+ bigshift = build_int_cst (type, 0);
+ else
+ {
+ tree nonneg = fold_build2_loc (input_location, GE_EXPR,
+ logical_type_node, args[0],
+ build_int_cst (TREE_TYPE (args[0]), 0));
+ bigshift = fold_build3_loc (input_location, COND_EXPR, type, nonneg,
+ build_int_cst (type, 0),
+ build_int_cst (type, -1));
+ }
+
/* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
gcc requires a shift width < BIT_SIZE(I), so we have to catch this
special case. */
num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
+
+ /* Optionally generate code for runtime argument check. */
+ if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
+ {
+ tree below = fold_build2_loc (input_location, LT_EXPR,
+ logical_type_node, args[1],
+ build_int_cst (TREE_TYPE (args[1]), 0));
+ tree above = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, args[1], num_bits);
+ tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ logical_type_node, below, above);
+ size_t len_name = strlen (expr->value.function.isym->name);
+ char *name = XALLOCAVEC (char, len_name + 1);
+ for (size_t i = 0; i < len_name; i++)
+ name[i] = TOUPPER (expr->value.function.isym->name[i]);
+ name[len_name] = '\0';
+ tree iname = gfc_build_addr_expr (pchar_type_node,
+ gfc_build_cstring_const (name));
+ gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
+ "SHIFT argument (%ld) out of range 0:%ld "
+ "in intrinsic %s",
+ fold_convert (long_integer_type_node, args[1]),
+ fold_convert (long_integer_type_node, num_bits),
+ iname);
+ }
+
cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
args[1], num_bits);
se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
- build_int_cst (type, 0), se->expr);
+ bigshift, se->expr);
}
/* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
gcc requires a shift width < BIT_SIZE(I), so we have to catch this
special case. */
num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
+
+ /* Optionally generate code for runtime argument check. */
+ if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
+ {
+ tree outside = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, width, num_bits);
+ gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
+ "SHIFT argument (%ld) out of range -%ld:%ld "
+ "in intrinsic ISHFT",
+ fold_convert (long_integer_type_node, args[1]),
+ fold_convert (long_integer_type_node, num_bits),
+ fold_convert (long_integer_type_node, num_bits));
+ }
+
cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width,
num_bits);
se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
tree lrot;
tree rrot;
tree zero;
+ tree nbits;
unsigned int num_args;
num_args = gfc_intrinsic_argument_list_length (expr);
gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+ type = TREE_TYPE (args[0]);
+ nbits = build_int_cst (long_integer_type_node, TYPE_PRECISION (type));
+
if (num_args == 3)
{
/* Use a library function for the 3 parameter version. */
tree int4type = gfc_get_int_type (4);
- type = TREE_TYPE (args[0]);
/* We convert the first argument to at least 4 bytes, and
convert back afterwards. This removes the need for library
functions for all argument sizes, and function will be
args[1] = convert (int4type, args[1]);
args[2] = convert (int4type, args[2]);
+ /* Optionally generate code for runtime argument check. */
+ if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
+ {
+ tree size = fold_convert (long_integer_type_node, args[2]);
+ tree below = fold_build2_loc (input_location, LE_EXPR,
+ logical_type_node, size,
+ build_int_cst (TREE_TYPE (args[1]), 0));
+ tree above = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, size, nbits);
+ tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ logical_type_node, below, above);
+ gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
+ "SIZE argument (%ld) out of range 1:%ld "
+ "in intrinsic ISHFTC", size, nbits);
+ tree width = fold_convert (long_integer_type_node, args[1]);
+ width = fold_build1_loc (input_location, ABS_EXPR,
+ long_integer_type_node, width);
+ scond = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, width, size);
+ gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
+ "SHIFT argument (%ld) out of range -%ld:%ld "
+ "in intrinsic ISHFTC",
+ fold_convert (long_integer_type_node, args[1]),
+ size, size);
+ }
+
switch (expr->ts.kind)
{
case 1:
return;
}
- type = TREE_TYPE (args[0]);
/* Evaluate arguments only once. */
args[0] = gfc_evaluate_now (args[0], &se->pre);
args[1] = gfc_evaluate_now (args[1], &se->pre);
+ /* Optionally generate code for runtime argument check. */
+ if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
+ {
+ tree width = fold_convert (long_integer_type_node, args[1]);
+ width = fold_build1_loc (input_location, ABS_EXPR,
+ long_integer_type_node, width);
+ tree outside = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, width, nbits);
+ gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
+ "SHIFT argument (%ld) out of range -%ld:%ld "
+ "in intrinsic ISHFTC",
+ fold_convert (long_integer_type_node, args[1]),
+ nbits, nbits);
+ }
+
/* Rotate left if positive. */
lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
tree fncall0;
tree fncall1;
gfc_se argse;
+ gfc_expr *e;
+ gfc_symbol *sym = NULL;
gfc_init_se (&argse, NULL);
actual = expr->value.function.actual;
if (actual->expr->ts.type == BT_CLASS)
gfc_add_class_array_ref (actual->expr);
+ e = actual->expr;
+
+ /* These are emerging from the interface mapping, when a class valued
+ function appears as the rhs in a realloc on assign statement, where
+ the size of the result is that of one of the actual arguments. */
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->ns == NULL /* This is distinctive! */
+ && e->symtree->n.sym->ts.type == BT_CLASS
+ && e->ref && e->ref->type == REF_COMPONENT
+ && strcmp (e->ref->u.c.component->name, "_data") == 0)
+ sym = e->symtree->n.sym;
+
+ if ((gfc_option.rtcheck & GFC_RTCHECK_POINTER)
+ && e
+ && (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION))
+ {
+ symbol_attribute attr;
+ char *msg;
+
+ attr = gfc_expr_attr (e);
+ if (attr.allocatable)
+ msg = xasprintf ("Allocatable argument '%s' is not allocated",
+ e->symtree->n.sym->name);
+ else if (attr.pointer)
+ msg = xasprintf ("Pointer argument '%s' is not associated",
+ e->symtree->n.sym->name);
+ else
+ goto end_arg_check;
+
+ argse.descriptor_only = 1;
+ gfc_conv_expr_descriptor (&argse, actual->expr);
+ tree temp = gfc_conv_descriptor_data_get (argse.expr);
+ tree cond = fold_build2_loc (input_location, EQ_EXPR,
+ logical_type_node, temp,
+ fold_convert (TREE_TYPE (temp),
+ null_pointer_node));
+ gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg);
+ free (msg);
+ }
+ end_arg_check:
+
argse.data_not_needed = 1;
- if (gfc_is_class_array_function (actual->expr))
+ if (gfc_is_class_array_function (e))
{
/* For functions that return a class array conv_expr_descriptor is not
able to get the descriptor right. Therefore this special case. */
- gfc_conv_expr_reference (&argse, actual->expr);
+ gfc_conv_expr_reference (&argse, e);
+ argse.expr = gfc_build_addr_expr (NULL_TREE,
+ gfc_class_data_get (argse.expr));
+ }
+ else if (sym && sym->backend_decl)
+ {
+ gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
+ argse.expr = sym->backend_decl;
argse.expr = gfc_build_addr_expr (NULL_TREE,
gfc_class_data_get (argse.expr));
}
gfc_se arg2se;
tree tmp2;
tree tmp;
- tree nonzero_charlen;
tree nonzero_arraylen;
gfc_ss *ss;
bool scalar;
if (arg2->expr->ts.type == BT_CLASS)
gfc_add_data_component (arg2->expr);
- nonzero_charlen = NULL_TREE;
- if (arg1->expr->ts.type == BT_CHARACTER)
- nonzero_charlen = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node,
- arg1->expr->ts.u.cl->backend_decl,
- build_zero_cst
- (TREE_TYPE (arg1->expr->ts.u.cl->backend_decl)));
if (scalar)
{
/* A pointer to a scalar. */
/* If target is present zero character length pointers cannot
be associated. */
- if (nonzero_charlen != NULL_TREE)
- se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
- logical_type_node,
- se->expr, nonzero_charlen);
+ if (arg1->expr->ts.type == BT_CHARACTER)
+ {
+ tmp = arg1se.string_length;
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, tmp,
+ build_zero_cst (TREE_TYPE (tmp)));
+ se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ logical_type_node, se->expr, tmp);
+ }
}
se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
conv_generic_with_optional_char_arg (se, expr, 1, 3);
break;
+ case GFC_ISYM_FINDLOC:
+ gfc_conv_intrinsic_findloc (se, expr);
+ break;
+
case GFC_ISYM_MINLOC:
gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
break;
gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
break;
+ case GFC_ISYM_ACOSD:
+ case GFC_ISYM_ASIND:
+ case GFC_ISYM_ATAND:
+ gfc_conv_intrinsic_atrigd (se, expr, expr->value.function.isym->id);
+ break;
+
+ case GFC_ISYM_COTAN:
+ gfc_conv_intrinsic_cotan (se, expr);
+ break;
+
+ case GFC_ISYM_COTAND:
+ gfc_conv_intrinsic_cotand (se, expr);
+ break;
+
+ case GFC_ISYM_ATAN2D:
+ gfc_conv_intrinsic_atan2d (se, expr);
+ break;
+
case GFC_ISYM_BTEST:
gfc_conv_intrinsic_btest (se, expr);
break;
break;
case GFC_ISYM_CONVERSION:
- case GFC_ISYM_REAL:
- case GFC_ISYM_LOGICAL:
case GFC_ISYM_DBLE:
+ case GFC_ISYM_DFLOAT:
+ case GFC_ISYM_FLOAT:
+ case GFC_ISYM_LOGICAL:
+ case GFC_ISYM_REAL:
+ case GFC_ISYM_REALPART:
+ case GFC_ISYM_SNGL:
gfc_conv_intrinsic_conversion (se, expr);
break;
gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
break;
+ case GFC_ISYM_IS_CONTIGUOUS:
+ gfc_conv_intrinsic_is_contiguous (se, expr);
+ break;
+
case GFC_ISYM_ISNAN:
gfc_conv_intrinsic_isnan (se, expr);
break;
gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
break;
+ case GFC_ISYM_FINDLOC:
+ gfc_conv_intrinsic_findloc (se, expr);
+ break;
+
case GFC_ISYM_MAXVAL:
gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
break;
bool
gfc_inline_intrinsic_function_p (gfc_expr *expr)
{
- gfc_actual_arglist *args;
+ gfc_actual_arglist *args, *dim_arg, *mask_arg;
+ gfc_expr *maskexpr;
if (!expr->value.function.isym)
return false;
return false;
args = expr->value.function.actual;
+ dim_arg = args->next;
+
/* We need to be able to subset the SUM argument at compile-time. */
- if (args->next->expr && args->next->expr->expr_type != EXPR_CONSTANT)
+ if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT)
+ return false;
+
+ /* FIXME: If MASK is optional for a more than two-dimensional
+ argument, the scalarizer gets confused if the mask is
+ absent. See PR 82995. For now, fall back to the library
+ function. */
+
+ mask_arg = dim_arg->next;
+ maskexpr = mask_arg->expr;
+
+ if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE
+ && maskexpr->symtree->n.sym->attr.dummy
+ && maskexpr->symtree->n.sym->attr.optional)
return false;
return true;
case GFC_ISYM_ALL:
case GFC_ISYM_ANY:
case GFC_ISYM_COUNT:
+ case GFC_ISYM_FINDLOC:
case GFC_ISYM_JN2:
case GFC_ISYM_IANY:
case GFC_ISYM_IALL:
}
}
-
static tree
conv_co_collective (gfc_code *code)
{
gfc_se argse;
stmtblock_t block, post_block;
- tree fndecl, array, strlen, image_index, stat, errmsg, errmsg_len;
+ tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len;
gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
gfc_start_block (&block);
gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
array = argse.expr;
}
+
gfc_add_block_to_block (&block, &argse.pre);
gfc_add_block_to_block (&post_block, &argse.post);
gcc_unreachable ();
}
- if (code->resolved_isym->id == GFC_ISYM_CO_SUM
- || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
- fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
- image_index, stat, errmsg, errmsg_len);
- else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
- fndecl = build_call_expr_loc (input_location, fndecl, 6, array, image_index,
- stat, errmsg, strlen, errmsg_len);
+ gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
+ ? code->ext.actual->expr->ts.u.derived : NULL;
+
+ if (derived && derived->attr.alloc_comp
+ && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
+ /* The derived type has the attribute 'alloc_comp'. */
+ {
+ tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr,
+ code->ext.actual->expr->rank,
+ image_index, stat, errmsg, errmsg_len);
+ gfc_add_expr_to_block (&block, tmp);
+ }
else
{
- tree opr, opr_flags;
-
- // FIXME: Handle TS29113's bind(C) strings with descriptor.
- int opr_flag_int;
- if (gfc_is_proc_ptr_comp (opr_expr))
- {
- gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
- opr_flag_int = sym->attr.dimension
- || (sym->ts.type == BT_CHARACTER
- && !sym->attr.is_bind_c)
- ? GFC_CAF_BYREF : 0;
- opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
- && !sym->attr.is_bind_c
- ? GFC_CAF_HIDDENLEN : 0;
- opr_flag_int |= sym->formal->sym->attr.value ? GFC_CAF_ARG_VALUE : 0;
- }
+ if (code->resolved_isym->id == GFC_ISYM_CO_SUM
+ || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
+ fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
+ image_index, stat, errmsg, errmsg_len);
+ else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
+ fndecl = build_call_expr_loc (input_location, fndecl, 6, array,
+ image_index, stat, errmsg,
+ strlen, errmsg_len);
else
{
- opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
- ? GFC_CAF_BYREF : 0;
- opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
- && !opr_expr->symtree->n.sym->attr.is_bind_c
- ? GFC_CAF_HIDDENLEN : 0;
- opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
- ? GFC_CAF_ARG_VALUE : 0;
+ tree opr, opr_flags;
+
+ // FIXME: Handle TS29113's bind(C) strings with descriptor.
+ int opr_flag_int;
+ if (gfc_is_proc_ptr_comp (opr_expr))
+ {
+ gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
+ opr_flag_int = sym->attr.dimension
+ || (sym->ts.type == BT_CHARACTER
+ && !sym->attr.is_bind_c)
+ ? GFC_CAF_BYREF : 0;
+ opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
+ && !sym->attr.is_bind_c
+ ? GFC_CAF_HIDDENLEN : 0;
+ opr_flag_int |= sym->formal->sym->attr.value
+ ? GFC_CAF_ARG_VALUE : 0;
+ }
+ else
+ {
+ opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
+ ? GFC_CAF_BYREF : 0;
+ opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
+ && !opr_expr->symtree->n.sym->attr.is_bind_c
+ ? GFC_CAF_HIDDENLEN : 0;
+ opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
+ ? GFC_CAF_ARG_VALUE : 0;
+ }
+ opr_flags = build_int_cst (integer_type_node, opr_flag_int);
+ gfc_conv_expr (&argse, opr_expr);
+ opr = argse.expr;
+ fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr,
+ opr_flags, image_index, stat, errmsg,
+ strlen, errmsg_len);
}
- opr_flags = build_int_cst (integer_type_node, opr_flag_int);
- gfc_conv_expr (&argse, opr_expr);
- opr = argse.expr;
- fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr, opr_flags,
- image_index, stat, errmsg, strlen, errmsg_len);
}
gfc_add_expr_to_block (&block, fndecl);
fn = (built_in_function) ((int) fn
+ exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
+ 1);
- tmp = builtin_decl_explicit (fn);
tree itype = TREE_TYPE (TREE_TYPE (atom));
tmp = builtin_decl_explicit (fn);
return gfc_finish_block (&se.pre);
}
+
+/* This is a peculiar case because of the need to do dependency checking.
+ It is called via trans-stmt.c(gfc_trans_call), where it is picked out as
+ a special case and this function called instead of
+ gfc_conv_procedure_call. */
+void
+gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args,
+ gfc_loopinfo *loop)
+{
+ gfc_actual_arglist *actual;
+ gfc_se argse[5];
+ gfc_expr *arg[5];
+ gfc_ss *lss;
+ int n;
+
+ tree from, frompos, len, to, topos;
+ tree lenmask, oldbits, newbits, bitsize;
+ tree type, utype, above, mask1, mask2;
+
+ if (loop)
+ lss = loop->ss;
+ else
+ lss = gfc_ss_terminator;
+
+ actual = actual_args;
+ for (n = 0; n < 5; n++, actual = actual->next)
+ {
+ arg[n] = actual->expr;
+ gfc_init_se (&argse[n], NULL);
+
+ if (lss != gfc_ss_terminator)
+ {
+ gfc_copy_loopinfo_to_se (&argse[n], loop);
+ /* Find the ss for the expression if it is there. */
+ argse[n].ss = lss;
+ gfc_mark_ss_chain_used (lss, 1);
+ }
+
+ gfc_conv_expr (&argse[n], arg[n]);
+
+ if (loop)
+ lss = argse[n].ss;
+ }
+
+ from = argse[0].expr;
+ frompos = argse[1].expr;
+ len = argse[2].expr;
+ to = argse[3].expr;
+ topos = argse[4].expr;
+
+ /* The type of the result (TO). */
+ type = TREE_TYPE (to);
+ bitsize = build_int_cst (integer_type_node, TYPE_PRECISION (type));
+
+ /* Optionally generate code for runtime argument check. */
+ if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
+ {
+ tree nbits, below, ccond;
+ tree fp = fold_convert (long_integer_type_node, frompos);
+ tree ln = fold_convert (long_integer_type_node, len);
+ tree tp = fold_convert (long_integer_type_node, topos);
+ below = fold_build2_loc (input_location, LT_EXPR,
+ logical_type_node, frompos,
+ build_int_cst (TREE_TYPE (frompos), 0));
+ above = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, frompos,
+ fold_convert (TREE_TYPE (frompos), bitsize));
+ ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ logical_type_node, below, above);
+ gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
+ &arg[1]->where,
+ "FROMPOS argument (%ld) out of range 0:%d "
+ "in intrinsic MVBITS", fp, bitsize);
+ below = fold_build2_loc (input_location, LT_EXPR,
+ logical_type_node, len,
+ build_int_cst (TREE_TYPE (len), 0));
+ above = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, len,
+ fold_convert (TREE_TYPE (len), bitsize));
+ ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ logical_type_node, below, above);
+ gfc_trans_runtime_check (true, false, ccond, &argse[2].pre,
+ &arg[2]->where,
+ "LEN argument (%ld) out of range 0:%d "
+ "in intrinsic MVBITS", ln, bitsize);
+ below = fold_build2_loc (input_location, LT_EXPR,
+ logical_type_node, topos,
+ build_int_cst (TREE_TYPE (topos), 0));
+ above = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, topos,
+ fold_convert (TREE_TYPE (topos), bitsize));
+ ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ logical_type_node, below, above);
+ gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
+ &arg[4]->where,
+ "TOPOS argument (%ld) out of range 0:%d "
+ "in intrinsic MVBITS", tp, bitsize);
+
+ /* The tests above ensure that FROMPOS, LEN and TOPOS fit into short
+ integers. Additions below cannot overflow. */
+ nbits = fold_convert (long_integer_type_node, bitsize);
+ above = fold_build2_loc (input_location, PLUS_EXPR,
+ long_integer_type_node, fp, ln);
+ ccond = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, above, nbits);
+ gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
+ &arg[1]->where,
+ "FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
+ "in intrinsic MVBITS", fp, ln, bitsize);
+ above = fold_build2_loc (input_location, PLUS_EXPR,
+ long_integer_type_node, tp, ln);
+ ccond = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, above, nbits);
+ gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
+ &arg[4]->where,
+ "TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
+ "in intrinsic MVBITS", tp, ln, bitsize);
+ }
+
+ for (n = 0; n < 5; n++)
+ {
+ gfc_add_block_to_block (&se->pre, &argse[n].pre);
+ gfc_add_block_to_block (&se->post, &argse[n].post);
+ }
+
+ /* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */
+ above = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
+ len, fold_convert (TREE_TYPE (len), bitsize));
+ mask1 = build_int_cst (type, -1);
+ mask2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
+ build_int_cst (type, 1), len);
+ mask2 = fold_build2_loc (input_location, MINUS_EXPR, type,
+ mask2, build_int_cst (type, 1));
+ lenmask = fold_build3_loc (input_location, COND_EXPR, type,
+ above, mask1, mask2);
+
+ /* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS.
+ * For valid frompos+len <= bit_size(FROM) the conversion to unsigned is
+ * not strictly necessary; artificial bits from rshift will be masked. */
+ utype = unsigned_type_for (type);
+ newbits = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
+ fold_convert (utype, from), frompos);
+ newbits = fold_build2_loc (input_location, BIT_AND_EXPR, type,
+ fold_convert (type, newbits), lenmask);
+ newbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
+ newbits, topos);
+
+ /* oldbits = TO & (~(lenmask << TOPOS)). */
+ oldbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
+ lenmask, topos);
+ oldbits = fold_build1_loc (input_location, BIT_NOT_EXPR, type, oldbits);
+ oldbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, oldbits, to);
+
+ /* TO = newbits | oldbits. */
+ se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
+ oldbits, newbits);
+
+ /* Return the assignment. */
+ se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
+ void_type_node, to, se->expr);
+}
+
+
static tree
conv_intrinsic_move_alloc (gfc_code *code)
{
res = conv_intrinsic_kill_sub (code);
break;
+ case GFC_ISYM_MVBITS:
+ res = NULL_TREE;
+ break;
+
case GFC_ISYM_SYSTEM_CLOCK:
res = conv_intrinsic_system_clock (code);
break;
projects / thirdparty / gcc.git / blobdiff