/* Intrinsic translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
/* This maps fortran intrinsic math functions to external library or GCC
builtin functions. */
-typedef struct gfc_intrinsic_map_t GTY(())
-{
+typedef struct GTY(()) gfc_intrinsic_map_t {
/* The explicit enum is required to work around inadequacies in the
garbage collection/gengtype parsing mechanism. */
enum gfc_isym_id id;
except for atan2. */
#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
{ GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
- BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \
- false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
- NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
+ BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, (enum built_in_function) 0, \
+ (enum built_in_function) 0, (enum built_in_function) 0, \
+ (enum built_in_function) 0, true, false, true, NAME, NULL_TREE, \
+ NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
+ NULL_TREE},
#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
{ GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
/* Call the library function that will perform the conversion. */
gcc_assert (nargs >= 2);
- tmp = build_call_expr (fndecl, 3, addr, args[0], args[1]);
+ tmp = build_call_expr_loc (input_location,
+ fndecl, 3, addr, args[0], args[1]);
gfc_add_expr_to_block (&se->pre, tmp);
/* Free the temporary afterwards. */
else
gcc_unreachable ();
- return fold_convert (restype, build_call_expr (fn, 1, arg));
+ return fold_convert (restype, build_call_expr_loc (input_location,
+ fn, 1, arg));
}
if (n != END_BUILTINS)
{
tmp = built_in_decls[n];
- se->expr = build_call_expr (tmp, 1, arg[0]);
+ se->expr = build_call_expr_loc (input_location,
+ tmp, 1, arg[0]);
return;
}
mpfr_init (huge);
n = gfc_validate_kind (BT_INTEGER, kind, false);
mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
- tmp = gfc_conv_mpfr_to_tree (huge, kind);
+ tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
cond = fold_build2 (LT_EXPR, boolean_type_node, arg[0], tmp);
mpfr_neg (huge, huge, GFC_RND_MODE);
- tmp = gfc_conv_mpfr_to_tree (huge, kind);
+ tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
tmp = fold_build2 (GT_EXPR, boolean_type_node, arg[0], tmp);
cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
itype = gfc_get_int_type (kind);
}
argtypes = gfc_chainon_list (argtypes, void_type_node);
type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
- fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
+ fndecl = build_decl (input_location,
+ FUNCTION_DECL, get_identifier (name), type);
/* Mark the decl as external. */
DECL_EXTERNAL (fndecl) = 1;
rettype = TREE_TYPE (TREE_TYPE (fndecl));
fndecl = build_addr (fndecl, current_function_decl);
- se->expr = build_call_array (rettype, fndecl, num_args, args);
+ se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
}
+
+/* If bounds-checking is enabled, create code to verify at runtime that the
+ string lengths for both expressions are the same (needed for e.g. MERGE).
+ If bounds-checking is not enabled, does nothing. */
+
+void
+gfc_trans_same_strlen_check (const char* intr_name, locus* where,
+ tree a, tree b, stmtblock_t* target)
+{
+ tree cond;
+ tree name;
+
+ /* If bounds-checking is disabled, do nothing. */
+ if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
+ return;
+
+ /* Compare the two string lengths. */
+ cond = fold_build2 (NE_EXPR, boolean_type_node, a, b);
+
+ /* Output the runtime-check. */
+ name = gfc_build_cstring_const (intr_name);
+ name = gfc_build_addr_expr (pchar_type_node, name);
+ gfc_trans_runtime_check (true, false, cond, target, where,
+ "Unequal character lengths (%ld/%ld) in %s",
+ fold_convert (long_integer_type_node, a),
+ fold_convert (long_integer_type_node, b), name);
+}
+
+
/* The EXPONENT(s) intrinsic function is translated into
int ret;
frexp (s, &ret);
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
res = gfc_create_var (integer_type_node, NULL);
- tmp = build_call_expr (built_in_decls[frexp], 2, arg,
- build_fold_addr_expr (res));
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[frexp], 2, arg,
+ gfc_build_addr_expr (NULL_TREE, res));
gfc_add_expr_to_block (&se->pre, tmp);
type = gfc_typenode_for_spec (&expr->ts);
tree type;
tree bound;
tree tmp;
- tree cond, cond1, cond2, cond3, cond4, size;
+ tree cond, cond1, cond3, cond4, size;
tree ubound;
tree lbound;
gfc_se argse;
gfc_ss *ss;
gfc_array_spec * as;
- gfc_ref *ref;
arg = expr->value.function.actual;
arg2 = arg->next;
}
else
{
- if (flag_bounds_check)
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
bound = gfc_evaluate_now (bound, &se->pre);
cond = fold_build2 (LT_EXPR, boolean_type_node,
}
}
- ubound = gfc_conv_descriptor_ubound (desc, bound);
- lbound = gfc_conv_descriptor_lbound (desc, bound);
+ ubound = gfc_conv_descriptor_ubound_get (desc, bound);
+ lbound = gfc_conv_descriptor_lbound_get (desc, bound);
- /* Follow any component references. */
- if (arg->expr->expr_type == EXPR_VARIABLE
- || arg->expr->expr_type == EXPR_CONSTANT)
- {
- as = arg->expr->symtree->n.sym->as;
- for (ref = arg->expr->ref; ref; ref = ref->next)
- {
- switch (ref->type)
- {
- case REF_COMPONENT:
- as = ref->u.c.component->as;
- continue;
-
- case REF_SUBSTRING:
- continue;
-
- case REF_ARRAY:
- {
- switch (ref->u.ar.type)
- {
- case AR_ELEMENT:
- case AR_SECTION:
- case AR_UNKNOWN:
- as = NULL;
- continue;
-
- case AR_FULL:
- break;
- }
- break;
- }
- }
- }
- }
- else
- as = NULL;
+ as = gfc_get_full_arrayspec_from_expr (arg->expr);
/* 13.14.53: Result value for LBOUND
if (as)
{
- tree stride = gfc_conv_descriptor_stride (desc, bound);
+ tree stride = gfc_conv_descriptor_stride_get (desc, bound);
cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
- cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
gfc_index_zero_node);
cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
gfc_index_zero_node);
- cond4 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond2);
if (upper)
{
+ tree cond5;
cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
+ cond5 = fold_build2 (EQ_EXPR, boolean_type_node, gfc_index_one_node, lbound);
+ cond5 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond5);
+
+ cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond5);
+
se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
ubound, gfc_index_zero_node);
}
default:
gcc_unreachable ();
}
- se->expr = build_call_expr (built_in_decls[n], 1, arg);
+ se->expr = build_call_expr_loc (input_location,
+ built_in_decls[n], 1, arg);
break;
default:
if (n != END_BUILTINS)
{
tmp = build_addr (built_in_decls[n], current_function_decl);
- se->expr = build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls[n])),
+ se->expr = build_call_array_loc (input_location,
+ TREE_TYPE (TREE_TYPE (built_in_decls[n])),
tmp, 2, args);
if (modulo == 0)
return;
ikind = gfc_max_integer_kind;
}
mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
- test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
+ test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
test2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, test);
mpfr_neg (huge, huge, GFC_RND_MODE);
- test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
+ test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
test = fold_build2 (GT_EXPR, boolean_type_node, tmp, test);
test2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
gfc_conv_intrinsic_function_args (se, expr, args, 2);
if (expr->ts.type == BT_REAL)
{
+ tree abs;
+
switch (expr->ts.kind)
{
case 4:
tmp = built_in_decls[BUILT_IN_COPYSIGNF];
+ abs = built_in_decls[BUILT_IN_FABSF];
break;
case 8:
tmp = built_in_decls[BUILT_IN_COPYSIGN];
+ abs = built_in_decls[BUILT_IN_FABS];
break;
case 10:
case 16:
tmp = built_in_decls[BUILT_IN_COPYSIGNL];
+ abs = built_in_decls[BUILT_IN_FABSL];
break;
default:
gcc_unreachable ();
}
- se->expr = build_call_expr (tmp, 2, args[0], args[1]);
+
+ /* We explicitly have to ignore the minus sign. We do so by using
+ result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
+ if (!gfc_option.flag_sign_zero
+ && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
+ {
+ tree cond, zero;
+ zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
+ cond = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
+ se->expr = fold_build3 (COND_EXPR, TREE_TYPE (args[0]), cond,
+ build_call_expr (abs, 1, args[0]),
+ build_call_expr (tmp, 2, args[0], args[1]));
+ }
+ else
+ se->expr = build_call_expr_loc (input_location,
+ tmp, 2, args[0], args[1]);
return;
}
len = gfc_create_var (gfc_get_int_type (8), "len");
gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
- args[0] = build_fold_addr_expr (var);
- args[1] = build_fold_addr_expr (len);
+ args[0] = gfc_build_addr_expr (NULL_TREE, var);
+ args[1] = gfc_build_addr_expr (NULL_TREE, len);
fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
- tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
+ tmp = build_call_array_loc (input_location,
+ TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
fndecl, num_args, args);
gfc_add_expr_to_block (&se->pre, tmp);
cond = fold_build2 (GT_EXPR, boolean_type_node,
len, build_int_cst (TREE_TYPE (len), 0));
tmp = gfc_call_free (var);
- tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->post, tmp);
se->expr = var;
len = gfc_create_var (gfc_get_int_type (4), "len");
gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
- args[0] = build_fold_addr_expr (var);
- args[1] = build_fold_addr_expr (len);
+ args[0] = gfc_build_addr_expr (NULL_TREE, var);
+ args[1] = gfc_build_addr_expr (NULL_TREE, len);
fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
- tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
+ tmp = build_call_array_loc (input_location,
+ TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
fndecl, num_args, args);
gfc_add_expr_to_block (&se->pre, tmp);
cond = fold_build2 (GT_EXPR, boolean_type_node,
len, build_int_cst (TREE_TYPE (len), 0));
tmp = gfc_call_free (var);
- tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->post, tmp);
se->expr = var;
len = gfc_create_var (gfc_get_int_type (4), "len");
gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
- args[0] = build_fold_addr_expr (var);
- args[1] = build_fold_addr_expr (len);
+ args[0] = gfc_build_addr_expr (NULL_TREE, var);
+ args[1] = gfc_build_addr_expr (NULL_TREE, len);
fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
- tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
+ tmp = build_call_array_loc (input_location,
+ TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
fndecl, num_args, args);
gfc_add_expr_to_block (&se->pre, tmp);
cond = fold_build2 (GT_EXPR, boolean_type_node,
len, build_int_cst (TREE_TYPE (len), 0));
tmp = gfc_call_free (var);
- tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->post, tmp);
se->expr = var;
/* TODO: Mismatching types can occur when specific names are used.
These should be handled during resolution. */
static void
-gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
tree tmp;
tree mvar;
if (argexpr->expr->expr_type == EXPR_VARIABLE
&& argexpr->expr->symtree->n.sym->attr.optional
&& TREE_CODE (val) == INDIRECT_REF)
- cond = fold_build2
- (NE_EXPR, boolean_type_node, TREE_OPERAND (val, 0),
- build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
+ cond = fold_build2_loc (input_location,
+ NE_EXPR, boolean_type_node,
+ TREE_OPERAND (val, 0),
+ build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
else
{
cond = NULL_TREE;
to help performance of programs that don't rely on IEEE semantics. */
if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
{
- isnan = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, mvar);
+ isnan = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_ISNAN], 1, mvar);
tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
fold_convert (boolean_type_node, isnan));
}
- tmp = build3_v (COND_EXPR, tmp, thencase, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, tmp, thencase,
+ build_empty_stmt (input_location));
if (cond != NULL_TREE)
- tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, cond, tmp,
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->pre, tmp);
argexpr = argexpr->next;
/* Create the result variables. */
len = gfc_create_var (gfc_charlen_type_node, "len");
- args[0] = build_fold_addr_expr (len);
+ args[0] = gfc_build_addr_expr (NULL_TREE, len);
var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
args[2] = build_int_cst (NULL_TREE, op);
/* Make the function call. */
fndecl = build_addr (function, current_function_decl);
- tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
+ tmp = build_call_array_loc (input_location,
+ TREE_TYPE (TREE_TYPE (function)), fndecl,
nargs + 4, args);
gfc_add_expr_to_block (&se->pre, tmp);
cond = fold_build2 (GT_EXPR, boolean_type_node,
len, build_int_cst (TREE_TYPE (len), 0));
tmp = gfc_call_free (var);
- tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->post, tmp);
se->expr = var;
}
}
- gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
+ gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
+ append_args);
gfc_free (sym);
}
}
*/
static void
-gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
tree resvar;
stmtblock_t block;
gfc_add_block_to_block (&body, &arrayse.pre);
tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
build_int_cst (TREE_TYPE (arrayse.expr), 0));
- tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
gfc_add_expr_to_block (&body, tmp);
gfc_add_block_to_block (&body, &arrayse.post);
gfc_copy_loopinfo_to_se (&arrayse, &loop);
arrayse.ss = arrayss;
gfc_conv_expr_val (&arrayse, actual->expr);
- tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
+ build_empty_stmt (input_location));
gfc_add_block_to_block (&body, &arrayse.pre);
gfc_add_expr_to_block (&body, tmp);
/* Inline implementation of the sum and product intrinsics. */
static void
-gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
tree resvar;
tree type;
/* We enclose the above in if (mask) {...} . */
tmp = gfc_finish_block (&block);
- tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+ build_empty_stmt (input_location));
}
else
tmp = gfc_finish_block (&block);
gfc_add_block_to_block (&block, &loop.post);
tmp = gfc_finish_block (&block);
- tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&se->pre, &block);
}
}
+/* 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.
+ Examples for minloc intrinsic:
+ 1) Result is an array, a call is generated
+ 2) Array mask is used and NaNs need to be supported:
+ limit = Infinity;
+ pos = 0;
+ S = from;
+ while (S <= to) {
+ if (mask[S]) {
+ if (pos == 0) pos = S + (1 - from);
+ if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
+ }
+ S++;
+ }
+ goto lab2;
+ lab1:;
+ while (S <= to) {
+ if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
+ S++;
+ }
+ lab2:;
+ 3) NaNs need to be supported, but it is known at compile time or cheaply
+ at runtime whether array is nonempty or not:
+ limit = Infinity;
+ pos = 0;
+ S = from;
+ while (S <= to) {
+ if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
+ S++;
+ }
+ if (from <= to) pos = 1;
+ goto lab2;
+ lab1:;
+ while (S <= to) {
+ if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
+ S++;
+ }
+ lab2:;
+ 4) NaNs aren't supported, array mask is used:
+ limit = infinities_supported ? Infinity : huge (limit);
+ pos = 0;
+ S = from;
+ while (S <= to) {
+ if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
+ S++;
+ }
+ goto lab2;
+ lab1:;
+ while (S <= to) {
+ if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
+ S++;
+ }
+ lab2:;
+ 5) Same without array mask:
+ limit = infinities_supported ? Infinity : huge (limit);
+ pos = (from <= to) ? 1 : 0;
+ S = from;
+ while (S <= to) {
+ if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
+ S++;
+ }
+ For 3) and 5), if mask is scalar, this all goes into a conditional,
+ setting pos = 0; in the else branch. */
+
static void
-gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
stmtblock_t body;
stmtblock_t block;
tree limit;
tree type;
tree tmp;
+ tree cond;
tree elsetmp;
tree ifbody;
tree offset;
+ tree nonempty;
+ tree lab1, lab2;
gfc_loopinfo loop;
gfc_actual_arglist *actual;
gfc_ss *arrayss;
actual = actual->next->next;
gcc_assert (actual);
maskexpr = actual->expr;
+ nonempty = NULL;
if (maskexpr && maskexpr->rank != 0)
{
maskss = gfc_walk_expr (maskexpr);
gcc_assert (maskss != gfc_ss_terminator);
}
else
- maskss = NULL;
+ {
+ mpz_t asize;
+ if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
+ {
+ nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
+ mpz_clear (asize);
+ nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
+ gfc_index_zero_node);
+ }
+ maskss = NULL;
+ }
limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
switch (arrayexpr->ts.type)
{
case BT_REAL:
- tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
+ if (HONOR_INFINITIES (DECL_MODE (limit)))
+ {
+ REAL_VALUE_TYPE real;
+ real_inf (&real);
+ tmp = build_real (TREE_TYPE (limit), real);
+ }
+ else
+ tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
+ arrayexpr->ts.kind, 0);
break;
case BT_INTEGER:
possible value is HUGE in both cases. */
if (op == GT_EXPR)
tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
- gfc_add_modify (&se->pre, limit, tmp);
-
if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
build_int_cst (type, 1));
+ gfc_add_modify (&se->pre, limit, tmp);
+
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, arrayss);
gfc_conv_loop_setup (&loop, &expr->where);
gcc_assert (loop.dimen == 1);
+ if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
+ nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
+ loop.to[0]);
+ lab1 = NULL;
+ lab2 = NULL;
/* Initialize the position to zero, following Fortran 2003. We are free
to do this because Fortran 95 allows the result of an entirely false
- mask to be processor dependent. */
- gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
+ mask to be processor dependent. If we know at compile time the array
+ is non-empty and no MASK is used, we can initialize to 1 to simplify
+ the inner loop. */
+ if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
+ gfc_add_modify (&loop.pre, pos,
+ fold_build3 (COND_EXPR, gfc_array_index_type,
+ nonempty, gfc_index_one_node,
+ gfc_index_zero_node));
+ else
+ {
+ gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
+ lab1 = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (lab1) = 1;
+ lab2 = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (lab2) = 1;
+ }
gfc_mark_ss_chain_used (arrayss, 1);
if (maskss)
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
gfc_index_one_node, loop.from[0]);
else
- tmp = build_int_cst (gfc_array_index_type, 1);
-
+ tmp = gfc_index_one_node;
+
gfc_add_modify (&block, offset, tmp);
+ if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
+ {
+ stmtblock_t ifblock2;
+ tree ifbody2;
+
+ gfc_start_block (&ifblock2);
+ tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
+ loop.loopvar[0], offset);
+ gfc_add_modify (&ifblock2, pos, tmp);
+ ifbody2 = gfc_finish_block (&ifblock2);
+ cond = fold_build2 (EQ_EXPR, boolean_type_node, pos,
+ gfc_index_zero_node);
+ tmp = build3_v (COND_EXPR, cond, ifbody2,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
loop.loopvar[0], offset);
gfc_add_modify (&ifblock, pos, tmp);
+ if (lab1)
+ gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
+
ifbody = gfc_finish_block (&ifblock);
- /* If it is a more extreme value or pos is still zero and the value
- equal to the limit. */
- tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
- fold_build2 (EQ_EXPR, boolean_type_node,
- pos, gfc_index_zero_node),
- fold_build2 (EQ_EXPR, boolean_type_node,
- arrayse.expr, limit));
- tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
- fold_build2 (op, boolean_type_node,
- arrayse.expr, limit), tmp);
- tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
- gfc_add_expr_to_block (&block, tmp);
+ if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
+ {
+ if (lab1)
+ cond = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
+ boolean_type_node, arrayse.expr, limit);
+ else
+ cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
+
+ ifbody = build3_v (COND_EXPR, cond, ifbody,
+ build_empty_stmt (input_location));
+ }
+ gfc_add_expr_to_block (&block, ifbody);
if (maskss)
{
/* We enclose the above in if (mask) {...}. */
tmp = gfc_finish_block (&block);
- tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, maskse.expr, 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_end (&loop, 0, &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));
+ gfc_start_block (&body);
+
+ /* 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);
+
+ /* Remember where we are. An offset must be added to the loop
+ counter to obtain the required position. */
+ if (loop.from[0])
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, loop.from[0]);
+ else
+ tmp = gfc_index_one_node;
+
+ gfc_add_modify (&block, offset, tmp);
+
+ tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
+ loop.loopvar[0], offset);
+ gfc_add_modify (&ifblock, pos, tmp);
+
+ ifbody = gfc_finish_block (&ifblock);
+
+ cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
+
+ 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) {...}. */
+ tmp = gfc_finish_block (&block);
+
+ tmp = build3_v (COND_EXPR, maskse.expr, 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)
{
se->expr = convert (type, pos);
}
+/* Emit code for minval or maxval 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.
+ Examples for minval intrinsic:
+ 1) Result is an array, a call is generated
+ 2) Array mask is used and NaNs need to be supported, rank 1:
+ limit = Infinity;
+ nonempty = false;
+ S = from;
+ while (S <= to) {
+ if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
+ S++;
+ }
+ limit = nonempty ? NaN : huge (limit);
+ lab:
+ while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
+ 3) NaNs need to be supported, but it is known at compile time or cheaply
+ at runtime whether array is nonempty or not, rank 1:
+ limit = Infinity;
+ S = from;
+ while (S <= to) { if (a[S] <= limit) goto lab; S++; }
+ limit = (from <= to) ? NaN : huge (limit);
+ lab:
+ while (S <= to) { limit = min (a[S], limit); S++; }
+ 4) Array mask is used and NaNs need to be supported, rank > 1:
+ limit = Infinity;
+ nonempty = false;
+ fast = false;
+ S1 = from1;
+ while (S1 <= to1) {
+ S2 = from2;
+ while (S2 <= to2) {
+ if (mask[S1][S2]) {
+ if (fast) limit = min (a[S1][S2], limit);
+ else {
+ nonempty = true;
+ if (a[S1][S2] <= limit) {
+ limit = a[S1][S2];
+ fast = true;
+ }
+ }
+ }
+ S2++;
+ }
+ S1++;
+ }
+ if (!fast)
+ limit = nonempty ? NaN : huge (limit);
+ 5) NaNs need to be supported, but it is known at compile time or cheaply
+ at runtime whether array is nonempty or not, rank > 1:
+ limit = Infinity;
+ fast = false;
+ S1 = from1;
+ while (S1 <= to1) {
+ S2 = from2;
+ while (S2 <= to2) {
+ if (fast) limit = min (a[S1][S2], limit);
+ else {
+ if (a[S1][S2] <= limit) {
+ limit = a[S1][S2];
+ fast = true;
+ }
+ }
+ S2++;
+ }
+ S1++;
+ }
+ if (!fast)
+ limit = (nonempty_array) ? NaN : huge (limit);
+ 6) NaNs aren't supported, but infinities are. Array mask is used:
+ limit = Infinity;
+ nonempty = false;
+ S = from;
+ while (S <= to) {
+ if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
+ S++;
+ }
+ limit = nonempty ? limit : huge (limit);
+ 7) Same without array mask:
+ limit = Infinity;
+ S = from;
+ while (S <= to) { limit = min (a[S], limit); S++; }
+ limit = (from <= to) ? limit : huge (limit);
+ 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
+ limit = huge (limit);
+ S = from;
+ while (S <= to) { limit = min (a[S], limit); S++); }
+ (or
+ while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
+ with array mask instead).
+ For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
+ setting limit = huge (limit); in the else branch. */
+
static void
-gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
tree limit;
tree type;
tree tmp;
tree ifbody;
+ tree nonempty;
+ tree nonempty_var;
+ tree lab;
+ tree fast;
+ tree huge_cst = NULL, nan_cst = NULL;
stmtblock_t body;
- stmtblock_t block;
+ stmtblock_t block, block2;
gfc_loopinfo loop;
gfc_actual_arglist *actual;
gfc_ss *arrayss;
switch (expr->ts.type)
{
case BT_REAL:
- tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
+ huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
+ expr->ts.kind, 0);
+ if (HONOR_INFINITIES (DECL_MODE (limit)))
+ {
+ REAL_VALUE_TYPE real;
+ real_inf (&real);
+ tmp = build_real (type, real);
+ }
+ else
+ tmp = huge_cst;
+ if (HONOR_NANS (DECL_MODE (limit)))
+ {
+ REAL_VALUE_TYPE real;
+ real_nan (&real, "", 1, DECL_MODE (limit));
+ nan_cst = build_real (type, real);
+ }
break;
case BT_INTEGER:
-HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
possible value is HUGE in both cases. */
if (op == GT_EXPR)
- tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
+ {
+ tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
+ if (huge_cst)
+ huge_cst = fold_build1 (NEGATE_EXPR, TREE_TYPE (huge_cst), huge_cst);
+ }
if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp),
actual = actual->next->next;
gcc_assert (actual);
maskexpr = actual->expr;
+ nonempty = NULL;
if (maskexpr && maskexpr->rank != 0)
{
maskss = gfc_walk_expr (maskexpr);
gcc_assert (maskss != gfc_ss_terminator);
}
else
- maskss = NULL;
+ {
+ mpz_t asize;
+ if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
+ {
+ nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
+ mpz_clear (asize);
+ nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
+ gfc_index_zero_node);
+ }
+ maskss = NULL;
+ }
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop, &expr->where);
+ if (nonempty == NULL && maskss == NULL
+ && loop.dimen == 1 && loop.from[0] && loop.to[0])
+ nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
+ loop.to[0]);
+ nonempty_var = NULL;
+ if (nonempty == NULL
+ && (HONOR_INFINITIES (DECL_MODE (limit))
+ || HONOR_NANS (DECL_MODE (limit))))
+ {
+ nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
+ gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
+ nonempty = nonempty_var;
+ }
+ lab = NULL;
+ fast = NULL;
+ if (HONOR_NANS (DECL_MODE (limit)))
+ {
+ if (loop.dimen == 1)
+ {
+ lab = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (lab) = 1;
+ }
+ else
+ {
+ fast = gfc_create_var (boolean_type_node, "fast");
+ gfc_add_modify (&se->pre, fast, boolean_false_node);
+ }
+ }
+
gfc_mark_ss_chain_used (arrayss, 1);
if (maskss)
gfc_mark_ss_chain_used (maskss, 1);
gfc_conv_expr_val (&arrayse, arrayexpr);
gfc_add_block_to_block (&block, &arrayse.pre);
- /* Assign the value to the limit... */
- ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
+ gfc_init_block (&block2);
+
+ if (nonempty_var)
+ gfc_add_modify (&block2, nonempty_var, boolean_true_node);
+
+ if (HONOR_NANS (DECL_MODE (limit)))
+ {
+ tmp = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
+ boolean_type_node, arrayse.expr, limit);
+ if (lab)
+ ifbody = build1_v (GOTO_EXPR, lab);
+ else
+ {
+ stmtblock_t ifblock;
+
+ gfc_init_block (&ifblock);
+ gfc_add_modify (&ifblock, limit, arrayse.expr);
+ gfc_add_modify (&ifblock, fast, boolean_true_node);
+ ifbody = gfc_finish_block (&ifblock);
+ }
+ tmp = build3_v (COND_EXPR, tmp, ifbody,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block2, tmp);
+ }
+ else
+ {
+ /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
+ signed zeros. */
+ if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
+ {
+ tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
+ ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
+ tmp = build3_v (COND_EXPR, tmp, ifbody,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block2, tmp);
+ }
+ else
+ {
+ tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
+ type, arrayse.expr, limit);
+ gfc_add_modify (&block2, limit, tmp);
+ }
+ }
+
+ if (fast)
+ {
+ tree elsebody = gfc_finish_block (&block2);
+
+ /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
+ signed zeros. */
+ if (HONOR_NANS (DECL_MODE (limit))
+ || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
+ {
+ tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
+ ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
+ ifbody = build3_v (COND_EXPR, tmp, ifbody,
+ build_empty_stmt (input_location));
+ }
+ else
+ {
+ tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
+ type, arrayse.expr, limit);
+ ifbody = build2_v (MODIFY_EXPR, limit, tmp);
+ }
+ tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else
+ gfc_add_block_to_block (&block, &block2);
- /* If it is a more extreme value. */
- tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
- tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
- gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &arrayse.post);
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 ());
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&body, tmp);
+ if (lab)
+ {
+ gfc_trans_scalarized_loop_end (&loop, 0, &body);
+
+ tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
+ gfc_add_modify (&loop.code[0], limit, tmp);
+ gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
+
+ gfc_start_block (&body);
+
+ /* If we have a mask, only add 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);
+
+ /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
+ signed zeros. */
+ if (HONOR_NANS (DECL_MODE (limit))
+ || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
+ {
+ tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
+ ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
+ tmp = build3_v (COND_EXPR, tmp, ifbody,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else
+ {
+ tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
+ type, arrayse.expr, limit);
+ gfc_add_modify (&block, limit, tmp);
+ }
+
+ gfc_add_block_to_block (&block, &arrayse.post);
+
+ 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));
+ 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 (fast)
+ {
+ tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
+ ifbody = build2_v (MODIFY_EXPR, limit, tmp);
+ tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
+ ifbody);
+ gfc_add_expr_to_block (&loop.pre, tmp);
+ }
+ else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
+ {
+ tmp = fold_build3 (COND_EXPR, type, nonempty, limit, huge_cst);
+ gfc_add_modify (&loop.pre, limit, tmp);
+ }
+
/* For a scalar mask, enclose the loop in an if statement. */
if (maskexpr && maskss == NULL)
{
+ tree else_stmt;
+
gfc_init_se (&maskse, NULL);
gfc_conv_expr_val (&maskse, maskexpr);
gfc_init_block (&block);
gfc_add_block_to_block (&block, &loop.post);
tmp = gfc_finish_block (&block);
- tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
+ if (HONOR_INFINITIES (DECL_MODE (limit)))
+ 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);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&se->pre, &block);
}
/* Generate code to perform the specified operation. */
static void
-gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
tree args[2];
tree args[2];
tree type;
tree tmp;
- int op;
+ enum tree_code op;
gfc_conv_intrinsic_function_args (se, expr, args, 2);
type = TREE_TYPE (args[0]);
default:
gcc_unreachable ();
}
- se->expr = build_call_expr (tmp, 3, args[0], args[1], args[2]);
+ se->expr = build_call_expr_loc (input_location,
+ tmp, 3, args[0], args[1], args[2]);
/* Convert the result back to the original type, if we extended
the first argument's width above. */
if (expr->ts.kind < 4)
se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
}
+/* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
+ : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
+
+ The conditional expression is necessary because the result of LEADZ(0)
+ is defined, but the result of __builtin_clz(0) is undefined for most
+ targets.
+
+ For INTEGER kinds smaller than the C 'int' type, we have to subtract the
+ difference in bit size between the argument of LEADZ and the C int. */
+
+static void
+gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
+{
+ tree arg;
+ tree arg_type;
+ tree cond;
+ tree result_type;
+ tree leadz;
+ tree bit_size;
+ tree tmp;
+ tree func;
+ int s, argsize;
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ argsize = TYPE_PRECISION (TREE_TYPE (arg));
+
+ /* Which variant of __builtin_clz* should we call? */
+ if (argsize <= INT_TYPE_SIZE)
+ {
+ arg_type = unsigned_type_node;
+ func = built_in_decls[BUILT_IN_CLZ];
+ }
+ else if (argsize <= LONG_TYPE_SIZE)
+ {
+ arg_type = long_unsigned_type_node;
+ func = built_in_decls[BUILT_IN_CLZL];
+ }
+ else if (argsize <= LONG_LONG_TYPE_SIZE)
+ {
+ arg_type = long_long_unsigned_type_node;
+ func = built_in_decls[BUILT_IN_CLZLL];
+ }
+ else
+ {
+ gcc_assert (argsize == 128);
+ arg_type = gfc_build_uint_type (argsize);
+ func = gfor_fndecl_clz128;
+ }
+
+ /* Convert the actual argument twice: first, to the unsigned type of the
+ same size; then, to the proper argument type for the built-in
+ function. But the return type is of the default INTEGER kind. */
+ arg = fold_convert (gfc_build_uint_type (argsize), arg);
+ arg = fold_convert (arg_type, arg);
+ result_type = gfc_get_int_type (gfc_default_integer_kind);
+
+ /* Compute LEADZ for the case i .ne. 0. */
+ s = TYPE_PRECISION (arg_type) - argsize;
+ tmp = fold_convert (result_type, build_call_expr (func, 1, arg));
+ leadz = fold_build2 (MINUS_EXPR, result_type,
+ tmp, build_int_cst (result_type, s));
+
+ /* Build BIT_SIZE. */
+ bit_size = build_int_cst (result_type, argsize);
+
+ cond = fold_build2 (EQ_EXPR, boolean_type_node,
+ arg, build_int_cst (arg_type, 0));
+ se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz);
+}
+
+/* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
+
+ The conditional expression is necessary because the result of TRAILZ(0)
+ is defined, but the result of __builtin_ctz(0) is undefined for most
+ targets. */
+
+static void
+gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
+{
+ tree arg;
+ tree arg_type;
+ tree cond;
+ tree result_type;
+ tree trailz;
+ tree bit_size;
+ tree func;
+ int argsize;
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ argsize = TYPE_PRECISION (TREE_TYPE (arg));
+
+ /* Which variant of __builtin_ctz* should we call? */
+ if (argsize <= INT_TYPE_SIZE)
+ {
+ arg_type = unsigned_type_node;
+ func = built_in_decls[BUILT_IN_CTZ];
+ }
+ else if (argsize <= LONG_TYPE_SIZE)
+ {
+ arg_type = long_unsigned_type_node;
+ func = built_in_decls[BUILT_IN_CTZL];
+ }
+ else if (argsize <= LONG_LONG_TYPE_SIZE)
+ {
+ arg_type = long_long_unsigned_type_node;
+ func = built_in_decls[BUILT_IN_CTZLL];
+ }
+ else
+ {
+ gcc_assert (argsize == 128);
+ arg_type = gfc_build_uint_type (argsize);
+ func = gfor_fndecl_ctz128;
+ }
+
+ /* Convert the actual argument twice: first, to the unsigned type of the
+ same size; then, to the proper argument type for the built-in
+ function. But the return type is of the default INTEGER kind. */
+ arg = fold_convert (gfc_build_uint_type (argsize), arg);
+ arg = fold_convert (arg_type, arg);
+ result_type = gfc_get_int_type (gfc_default_integer_kind);
+
+ /* Compute TRAILZ for the case i .ne. 0. */
+ trailz = fold_convert (result_type, build_call_expr_loc (input_location,
+ func, 1, arg));
+
+ /* Build BIT_SIZE. */
+ bit_size = build_int_cst (result_type, argsize);
+
+ cond = fold_build2 (EQ_EXPR, boolean_type_node,
+ arg, build_int_cst (arg_type, 0));
+ se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz);
+}
/* Process an intrinsic with unspecified argument-types that has an optional
argument (which could be of type character), e.g. EOSHIFT. For those, we
/* Build the call itself. */
sym = gfc_get_symbol_for_expr (expr);
- gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
+ gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
+ append_args);
gfc_free (sym);
}
&& (sym->result == sym))
decl = gfc_get_fake_result_decl (sym, 0);
- len = sym->ts.cl->backend_decl;
+ len = sym->ts.u.cl->backend_decl;
gcc_assert (len);
break;
}
else
gcc_unreachable ();
- se->expr = build_call_expr (fndecl, 2, args[0], args[1]);
+ se->expr = build_call_expr_loc (input_location,
+ fndecl, 2, args[0], args[1]);
se->expr = convert (type, se->expr);
}
args[4] = convert (logical4_type_node, args[4]);
fndecl = build_addr (function, current_function_decl);
- se->expr = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
+ se->expr = build_call_array_loc (input_location,
+ TREE_TYPE (TREE_TYPE (function)), fndecl,
5, args);
se->expr = convert (type, se->expr);
args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]);
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = build_fold_indirect_ref (args[1]);
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ args[1]);
se->expr = convert (type, se->expr);
}
tree arg;
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
- se->expr = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, arg);
+ se->expr = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_ISNAN], 1, arg);
STRIP_TYPE_NOPS (se->expr);
se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
}
tree fsource;
tree mask;
tree type;
- tree len;
+ tree len, len2;
tree *args;
unsigned int num_args;
also have to set the string length for the result. */
len = args[0];
tsource = args[1];
+ len2 = args[2];
fsource = args[3];
mask = args[4];
+ gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
+ &se->pre);
se->string_length = len;
}
type = TREE_TYPE (tsource);
type = gfc_typenode_for_spec (&expr->ts);
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
tmp = gfc_create_var (integer_type_node, NULL);
- se->expr = build_call_expr (built_in_decls[frexp], 2,
+ se->expr = build_call_expr_loc (input_location,
+ built_in_decls[frexp], 2,
fold_convert (type, arg),
- build_fold_addr_expr (tmp));
+ gfc_build_addr_expr (NULL_TREE, tmp));
se->expr = fold_convert (type, se->expr);
}
/* NEAREST (s, dir) is translated into
- tmp = copysign (INF, dir);
+ tmp = copysign (HUGE_VAL, dir);
return nextafter (s, tmp);
*/
static void
gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
{
tree args[2], type, tmp;
- int nextafter, copysign, inf;
+ int nextafter, copysign, huge_val;
switch (expr->ts.kind)
{
case 4:
nextafter = BUILT_IN_NEXTAFTERF;
copysign = BUILT_IN_COPYSIGNF;
- inf = BUILT_IN_INFF;
+ huge_val = BUILT_IN_HUGE_VALF;
break;
case 8:
nextafter = BUILT_IN_NEXTAFTER;
copysign = BUILT_IN_COPYSIGN;
- inf = BUILT_IN_INF;
+ huge_val = BUILT_IN_HUGE_VAL;
break;
case 10:
case 16:
nextafter = BUILT_IN_NEXTAFTERL;
copysign = BUILT_IN_COPYSIGNL;
- inf = BUILT_IN_INFL;
+ huge_val = BUILT_IN_HUGE_VALL;
break;
default:
gcc_unreachable ();
type = gfc_typenode_for_spec (&expr->ts);
gfc_conv_intrinsic_function_args (se, expr, args, 2);
- tmp = build_call_expr (built_in_decls[copysign], 2,
- build_call_expr (built_in_decls[inf], 0),
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[copysign], 2,
+ build_call_expr_loc (input_location,
+ built_in_decls[huge_val], 0),
fold_convert (type, args[1]));
- se->expr = build_call_expr (built_in_decls[nextafter], 2,
+ se->expr = build_call_expr_loc (input_location,
+ built_in_decls[nextafter], 2,
fold_convert (type, args[0]), tmp);
se->expr = fold_convert (type, se->expr);
}
k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
prec = build_int_cst (NULL_TREE, gfc_real_kinds[k].digits);
emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1);
- tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind);
+ tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
switch (expr->ts.kind)
{
/* Build the block for s /= 0. */
gfc_start_block (&block);
- tmp = build_call_expr (built_in_decls[frexp], 2, arg,
- build_fold_addr_expr (e));
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[frexp], 2, arg,
+ gfc_build_addr_expr (NULL_TREE, e));
gfc_add_expr_to_block (&block, tmp);
tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec);
gfc_add_modify (&block, e, fold_build2 (MAX_EXPR, integer_type_node,
- tmp, emin));
+ tmp, emin));
- tmp = build_call_expr (built_in_decls[scalbn], 2,
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[scalbn], 2,
build_real_from_int_cst (type, integer_one_node), e);
gfc_add_modify (&block, res, tmp);
e = gfc_create_var (integer_type_node, NULL);
x = gfc_create_var (type, NULL);
gfc_add_modify (&se->pre, x,
- build_call_expr (built_in_decls[fabs], 1, arg));
+ build_call_expr_loc (input_location,
+ built_in_decls[fabs], 1, arg));
gfc_start_block (&block);
- tmp = build_call_expr (built_in_decls[frexp], 2, arg,
- build_fold_addr_expr (e));
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[frexp], 2, arg,
+ gfc_build_addr_expr (NULL_TREE, e));
gfc_add_expr_to_block (&block, tmp);
tmp = fold_build2 (MINUS_EXPR, integer_type_node,
build_int_cst (NULL_TREE, prec), e);
- tmp = build_call_expr (built_in_decls[scalbn], 2, x, tmp);
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[scalbn], 2, x, tmp);
gfc_add_modify (&block, x, tmp);
stmt = gfc_finish_block (&block);
cond = fold_build2 (NE_EXPR, boolean_type_node, x,
build_real_from_int_cst (type, integer_zero_node));
- tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = fold_convert (type, x);
type = gfc_typenode_for_spec (&expr->ts);
gfc_conv_intrinsic_function_args (se, expr, args, 2);
- se->expr = build_call_expr (built_in_decls[scalbn], 2,
+ se->expr = build_call_expr_loc (input_location,
+ built_in_decls[scalbn], 2,
fold_convert (type, args[0]),
fold_convert (integer_type_node, args[1]));
se->expr = fold_convert (type, se->expr);
gfc_conv_intrinsic_function_args (se, expr, args, 2);
tmp = gfc_create_var (integer_type_node, NULL);
- tmp = build_call_expr (built_in_decls[frexp], 2,
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[frexp], 2,
fold_convert (type, args[0]),
- build_fold_addr_expr (tmp));
- se->expr = build_call_expr (built_in_decls[scalbn], 2, tmp,
+ gfc_build_addr_expr (NULL_TREE, tmp));
+ se->expr = build_call_expr_loc (input_location,
+ built_in_decls[scalbn], 2, tmp,
fold_convert (integer_type_node, args[1]));
se->expr = fold_convert (type, se->expr);
}
arg1 = gfc_evaluate_now (argse.expr, &se->pre);
/* Build the call to size0. */
- fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1);
+ fncall0 = build_call_expr_loc (input_location,
+ gfor_fndecl_size0, 1, arg1);
actual = actual->next;
gfc_array_index_type);
gfc_add_block_to_block (&se->pre, &argse.pre);
- /* Build the call to size1. */
- fncall1 = build_call_expr (gfor_fndecl_size1, 2,
- arg1, argse.expr);
-
/* Unusually, for an intrinsic, size does not exclude
an optional arg2, so we must test for it. */
if (actual->expr->expr_type == EXPR_VARIABLE
&& actual->expr->symtree->n.sym->attr.optional)
{
tree tmp;
+ /* Build the call to size1. */
+ fncall1 = build_call_expr_loc (input_location,
+ gfor_fndecl_size1, 2,
+ arg1, argse.expr);
+
gfc_init_se (&argse, NULL);
argse.want_pointer = 1;
argse.data_not_needed = 1;
tmp, fncall1, fncall0);
}
else
- se->expr = fncall1;
+ {
+ se->expr = NULL_TREE;
+ argse.expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ argse.expr, gfc_index_one_node);
+ }
+ }
+ else if (expr->value.function.actual->expr->rank == 1)
+ {
+ argse.expr = gfc_index_zero_node;
+ se->expr = NULL_TREE;
}
else
se->expr = fncall0;
+ if (se->expr == NULL_TREE)
+ {
+ tree ubound, lbound;
+
+ arg1 = build_fold_indirect_ref_loc (input_location,
+ arg1);
+ ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
+ lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
+ se->expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ ubound, lbound);
+ se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, se->expr,
+ gfc_index_one_node);
+ se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
+ gfc_index_zero_node);
+ }
+
type = gfc_typenode_for_spec (&expr->ts);
se->expr = convert (type, se->expr);
}
gfc_expr *arg;
gfc_ss *ss;
gfc_se argse;
- tree source;
tree source_bytes;
tree type;
tree tmp;
if (ss == gfc_ss_terminator)
{
gfc_conv_expr_reference (&argse, arg);
- source = argse.expr;
- type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
+ type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
+ argse.expr));
/* Obtain the source word length. */
if (arg->ts.type == BT_CHARACTER)
source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
argse.want_pointer = 0;
gfc_conv_expr_descriptor (&argse, arg, ss);
- source = gfc_conv_descriptor_data_get (argse.expr);
type = gfc_get_element_type (TREE_TYPE (argse.expr));
/* Obtain the argument's word length. */
{
tree idx;
idx = gfc_rank_cst[n];
- lower = gfc_conv_descriptor_lbound (argse.expr, idx);
- upper = gfc_conv_descriptor_ubound (argse.expr, idx);
+ lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
+ upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
upper, lower);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
/* Intrinsic string comparison functions. */
static void
-gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
tree args[4];
var = gfc_conv_string_tmp (se, type, len);
args[0] = var;
- tmp = build_call_expr (fndecl, 3, args[0], args[1], args[2]);
+ tmp = build_call_expr_loc (input_location,
+ fndecl, 3, args[0], args[1], args[2]);
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = var;
se->string_length = len;
}
-/* Array transfer statement.
- DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
- where:
- typeof<DEST> = typeof<MOLD>
- and:
- N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
+/* Generate code for the TRANSFER intrinsic:
+ For scalar results:
+ DEST = TRANSFER (SOURCE, MOLD)
+ where:
+ typeof<DEST> = typeof<MOLD>
+ and:
+ MOLD is scalar.
+
+ For array results:
+ DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
+ where:
+ typeof<DEST> = typeof<MOLD>
+ and:
+ N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
sizeof (DEST(0) * SIZE). */
-
static void
-gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
{
tree tmp;
+ tree tmpdecl;
+ tree ptr;
tree extent;
tree source;
tree source_type;
tree size_bytes;
tree upper;
tree lower;
- tree stride;
tree stmt;
gfc_actual_arglist *arg;
gfc_se argse;
gfc_ss_info *info;
stmtblock_t block;
int n;
+ bool scalar_mold;
- gcc_assert (se->loop);
- info = &se->ss->data.info;
+ info = NULL;
+ if (se->loop)
+ info = &se->ss->data.info;
/* Convert SOURCE. The output from this stage is:-
source_bytes = length of the source in bytes
source = pointer to the source data. */
arg = expr->value.function.actual;
+
+ /* Ensure double transfer through LOGICAL preserves all
+ the needed bits. */
+ if (arg->expr->expr_type == EXPR_FUNCTION
+ && arg->expr->value.function.esym == NULL
+ && arg->expr->value.function.isym != NULL
+ && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
+ && arg->expr->ts.type == BT_LOGICAL
+ && expr->ts.type != arg->expr->ts.type)
+ arg->expr->value.function.name = "__transfer_in_transfer";
+
gfc_init_se (&argse, NULL);
ss = gfc_walk_expr (arg->expr);
gfc_conv_expr_reference (&argse, arg->expr);
source = argse.expr;
- source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
+ source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
+ argse.expr));
/* Obtain the source word length. */
if (arg->expr->ts.type == BT_CHARACTER)
source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
/* Repack the source if not a full variable array. */
- if (!(arg->expr->expr_type == EXPR_VARIABLE
- && arg->expr->ref->u.ar.type == AR_FULL))
+ if (arg->expr->expr_type == EXPR_VARIABLE
+ && arg->expr->ref->u.ar.type != AR_FULL)
{
- tmp = build_fold_addr_expr (argse.expr);
+ tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
if (gfc_option.warn_array_temp)
gfc_warning ("Creating array temporary at %L", &expr->where);
- source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
+ source = build_call_expr_loc (input_location,
+ gfor_fndecl_in_pack, 1, tmp);
source = gfc_evaluate_now (source, &argse.pre);
/* Free the temporary. */
gfc_init_block (&block);
tmp = gfc_conv_array_data (argse.expr);
tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp);
- tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, tmp, stmt,
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &se->post);
gfc_init_block (&se->post);
tree idx;
idx = gfc_rank_cst[n];
gfc_add_modify (&argse.pre, source_bytes, tmp);
- stride = gfc_conv_descriptor_stride (argse.expr, idx);
- lower = gfc_conv_descriptor_lbound (argse.expr, idx);
- upper = gfc_conv_descriptor_ubound (argse.expr, idx);
+ lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
+ upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
upper, lower);
gfc_add_modify (&argse.pre, extent, tmp);
gfc_init_se (&argse, NULL);
ss = gfc_walk_expr (arg->expr);
+ scalar_mold = arg->expr->rank == 0;
+
if (ss == gfc_ss_terminator)
{
gfc_conv_expr_reference (&argse, arg->expr);
- mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
+ mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
+ argse.expr));
}
else
{
mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
}
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+
+ if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
+ {
+ /* If this TRANSFER is nested in another TRANSFER, use a type
+ that preserves all bits. */
+ if (arg->expr->ts.type == BT_LOGICAL)
+ mold_type = gfc_get_int_type (arg->expr->ts.kind);
+ }
+
if (arg->expr->ts.type == BT_CHARACTER)
{
tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
gfc_init_se (&argse, NULL);
gfc_conv_expr_reference (&argse, arg->expr);
tmp = convert (gfc_array_index_type,
- build_fold_indirect_ref (argse.expr));
+ build_fold_indirect_ref_loc (input_location,
+ argse.expr));
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
}
else
tmp = NULL_TREE;
+ /* Separate array and scalar results. */
+ if (scalar_mold && tmp == NULL_TREE)
+ goto scalar_transfer;
+
size_bytes = gfc_create_var (gfc_array_index_type, NULL);
if (tmp != NULL_TREE)
- {
- tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
- tmp, dest_word_len);
- tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
- tmp, source_bytes);
- }
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ tmp, dest_word_len);
else
tmp = source_bytes;
se->loop->to[n] = upper;
/* Build a destination descriptor, using the pointer, source, as the
- data field. This is already allocated so set callee_alloc.
- FIXME callee_alloc is not set! */
-
+ data field. */
gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
- info, mold_type, false, true, false,
+ info, mold_type, NULL_TREE, false, true, false,
&expr->where);
/* Cast the pointer to the result. */
tmp = fold_convert (pvoid_type_node, tmp);
/* Use memcpy to do the transfer. */
- tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMCPY],
3,
tmp,
fold_convert (pvoid_type_node, source),
- size_bytes);
+ fold_build2 (MIN_EXPR, gfc_array_index_type,
+ size_bytes, source_bytes));
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = info->descriptor;
if (expr->ts.type == BT_CHARACTER)
se->string_length = dest_word_len;
-}
+ return;
-/* Scalar transfer statement.
- TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl. */
+/* Deal with scalar results. */
+scalar_transfer:
+ extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
+ dest_word_len, source_bytes);
+ extent = fold_build2 (MAX_EXPR, gfc_array_index_type,
+ extent, gfc_index_zero_node);
-static void
-gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
-{
- gfc_actual_arglist *arg;
- gfc_se argse;
- tree type;
- tree ptr;
- gfc_ss *ss;
- tree tmpdecl, tmp;
+ if (expr->ts.type == BT_CHARACTER)
+ {
+ tree direct;
+ tree indirect;
- /* Get a pointer to the source. */
- arg = expr->value.function.actual;
- ss = gfc_walk_expr (arg->expr);
- gfc_init_se (&argse, NULL);
- if (ss == gfc_ss_terminator)
- gfc_conv_expr_reference (&argse, arg->expr);
- else
- gfc_conv_array_parameter (&argse, arg->expr, ss, 1, NULL, NULL);
- gfc_add_block_to_block (&se->pre, &argse.pre);
- gfc_add_block_to_block (&se->post, &argse.post);
- ptr = argse.expr;
+ ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
+ tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
+ "transfer");
- arg = arg->next;
- type = gfc_typenode_for_spec (&expr->ts);
+ /* If source is longer than the destination, use a pointer to
+ the source directly. */
+ gfc_init_block (&block);
+ gfc_add_modify (&block, tmpdecl, ptr);
+ direct = gfc_finish_block (&block);
- if (expr->ts.type == BT_CHARACTER)
- {
- ptr = convert (build_pointer_type (type), ptr);
- gfc_init_se (&argse, NULL);
- gfc_conv_expr (&argse, arg->expr);
- gfc_add_block_to_block (&se->pre, &argse.pre);
- gfc_add_block_to_block (&se->post, &argse.post);
- se->expr = ptr;
- se->string_length = argse.string_length;
+ /* Otherwise, allocate a string with the length of the destination
+ and copy the source into it. */
+ gfc_init_block (&block);
+ tmp = gfc_get_pchar_type (expr->ts.kind);
+ tmp = gfc_call_malloc (&block, tmp, dest_word_len);
+ gfc_add_modify (&block, tmpdecl,
+ fold_convert (TREE_TYPE (ptr), tmp));
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMCPY], 3,
+ fold_convert (pvoid_type_node, tmpdecl),
+ fold_convert (pvoid_type_node, ptr),
+ extent);
+ gfc_add_expr_to_block (&block, tmp);
+ indirect = gfc_finish_block (&block);
+
+ /* Wrap it up with the condition. */
+ tmp = fold_build2 (LE_EXPR, boolean_type_node,
+ dest_word_len, source_bytes);
+ tmp = build3_v (COND_EXPR, tmp, direct, indirect);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ se->expr = tmpdecl;
+ se->string_length = dest_word_len;
}
else
{
- tree moldsize;
- tmpdecl = gfc_create_var (type, "transfer");
- moldsize = size_in_bytes (type);
+ tmpdecl = gfc_create_var (mold_type, "transfer");
+
+ ptr = convert (build_pointer_type (mold_type), source);
/* Use memcpy to do the transfer. */
- tmp = build_fold_addr_expr (tmpdecl);
- tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+ tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMCPY], 3,
fold_convert (pvoid_type_node, tmp),
fold_convert (pvoid_type_node, ptr),
- moldsize);
+ extent);
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = tmpdecl;
gfc_init_se (&arg1se, NULL);
arg1 = expr->value.function.actual;
ss1 = gfc_walk_expr (arg1->expr);
- arg1se.descriptor_only = 1;
- gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
- tmp = gfc_conv_descriptor_data_get (arg1se.expr);
+ if (ss1 == gfc_ss_terminator)
+ {
+ /* Allocatable scalar. */
+ arg1se.want_pointer = 1;
+ gfc_conv_expr (&arg1se, arg1->expr);
+ tmp = arg1se.expr;
+ }
+ else
+ {
+ /* Allocatable array. */
+ arg1se.descriptor_only = 1;
+ gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
+ tmp = gfc_conv_descriptor_data_get (arg1se.expr);
+ }
+
tmp = fold_build2 (NE_EXPR, boolean_type_node,
tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node));
se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
gfc_init_se (&arg1se, NULL);
gfc_init_se (&arg2se, NULL);
arg1 = expr->value.function.actual;
+ if (arg1->expr->ts.type == BT_CLASS)
+ gfc_add_component_ref (arg1->expr, "$data");
arg2 = arg1->next;
ss1 = gfc_walk_expr (arg1->expr);
nonzero_charlen = NULL_TREE;
if (arg1->expr->ts.type == BT_CHARACTER)
nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
- arg1->expr->ts.cl->backend_decl,
+ arg1->expr->ts.u.cl->backend_decl,
integer_zero_node);
if (ss1 == gfc_ss_terminator)
present. */
arg1se.descriptor_only = 1;
gfc_conv_expr_lhs (&arg1se, arg1->expr);
- tmp = gfc_conv_descriptor_stride (arg1se.expr,
+ tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
gfc_rank_cst[arg1->expr->rank - 1]);
nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp,
build_int_cst (TREE_TYPE (tmp), 0));
gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
gfc_add_block_to_block (&se->pre, &arg2se.pre);
gfc_add_block_to_block (&se->post, &arg2se.post);
- se->expr = build_call_expr (gfor_fndecl_associated, 2,
+ se->expr = build_call_expr_loc (input_location,
+ gfor_fndecl_associated, 2,
arg1se.expr, arg2se.expr);
se->expr = convert (boolean_type_node, se->expr);
se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
}
+/* Generate code for the SAME_TYPE_AS intrinsic.
+ Generate inline code that directly checks the vindices. */
+
+static void
+gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
+{
+ gfc_expr *a, *b;
+ gfc_se se1, se2;
+ tree tmp;
+
+ gfc_init_se (&se1, NULL);
+ gfc_init_se (&se2, NULL);
+
+ a = expr->value.function.actual->expr;
+ b = expr->value.function.actual->next->expr;
+
+ if (a->ts.type == BT_CLASS)
+ {
+ gfc_add_component_ref (a, "$vptr");
+ gfc_add_component_ref (a, "$hash");
+ }
+ else if (a->ts.type == BT_DERIVED)
+ a = gfc_int_expr (a->ts.u.derived->hash_value);
+
+ if (b->ts.type == BT_CLASS)
+ {
+ gfc_add_component_ref (b, "$vptr");
+ gfc_add_component_ref (b, "$hash");
+ }
+ else if (b->ts.type == BT_DERIVED)
+ b = gfc_int_expr (b->ts.u.derived->hash_value);
+
+ gfc_conv_expr (&se1, a);
+ gfc_conv_expr (&se2, b);
+
+ tmp = fold_build2 (EQ_EXPR, boolean_type_node,
+ se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
+ se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
+}
+
+
/* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
static void
tree args[2];
gfc_conv_intrinsic_function_args (se, expr, args, 2);
- se->expr = build_call_expr (gfor_fndecl_sc_kind, 2, args[0], args[1]);
+ se->expr = build_call_expr_loc (input_location,
+ gfor_fndecl_sc_kind, 2, args[0], args[1]);
se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
}
/* The argument to SELECTED_INT_KIND is INTEGER(4). */
type = gfc_get_int_type (4);
- arg = build_fold_addr_expr (fold_convert (type, arg));
+ arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
/* Convert it to the required type. */
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg);
+ se->expr = build_call_expr_loc (input_location,
+ gfor_fndecl_si_kind, 1, arg);
se->expr = fold_convert (type, se->expr);
}
/* Convert it to the required type. */
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
+ se->expr = build_function_call_expr (input_location,
+ gfor_fndecl_sr_kind, args);
se->expr = fold_convert (type, se->expr);
}
len = gfc_create_var (gfc_get_int_type (4), "len");
gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
- args[0] = build_fold_addr_expr (len);
+ args[0] = gfc_build_addr_expr (NULL_TREE, len);
args[1] = addr;
if (expr->ts.kind == 1)
gcc_unreachable ();
fndecl = build_addr (function, current_function_decl);
- tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
+ tmp = build_call_array_loc (input_location,
+ TREE_TYPE (TREE_TYPE (function)), fndecl,
num_args, args);
gfc_add_expr_to_block (&se->pre, tmp);
cond = fold_build2 (GT_EXPR, boolean_type_node,
len, build_int_cst (TREE_TYPE (len), 0));
tmp = gfc_call_free (var);
- tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->post, tmp);
se->expr = var;
dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
fold_convert (gfc_charlen_type_node, slen),
fold_convert (gfc_charlen_type_node, ncopies));
- type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
+ type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
/* Generate the code to do the repeat operation:
tmp = build1_v (GOTO_EXPR, exit_label);
TREE_USED (exit_label) = 1;
tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
- build_empty_stmt ());
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&body, tmp);
/* Call memmove (dest + (i*slen*size), src, slen*size). */
tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
fold_convert (pvoid_type_node, dest),
fold_convert (sizetype, tmp));
- tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
fold_build2 (MULT_EXPR, size_type_node, slen,
fold_convert (size_type_node, size)));
gfc_add_expr_to_block (&body, tmp);
/* Call the library function. This always returns an INTEGER(4). */
fndecl = gfor_fndecl_iargc;
- tmp = build_call_expr (fndecl, 0);
+ tmp = build_call_expr_loc (input_location,
+ fndecl, 0);
/* Convert it to the required type. */
type = gfc_typenode_for_spec (&expr->ts);
if (ss == gfc_ss_terminator)
gfc_conv_expr_reference (se, arg_expr);
else
- gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL);
+ gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL);
se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
/* Create a temporary variable for loc return value. Without this,
void
gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
{
- gfc_intrinsic_sym *isym;
const char *name;
int lib, kind;
tree fndecl;
- isym = expr->value.function.isym;
-
name = &expr->value.function.name[2];
if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
gfc_conv_associated(se, expr);
break;
+ case GFC_ISYM_SAME_TYPE_AS:
+ gfc_conv_same_type_as (se, expr);
+ break;
+
case GFC_ISYM_ABS:
gfc_conv_intrinsic_abs (se, expr);
break;
gfc_conv_intrinsic_ishftc (se, expr);
break;
+ case GFC_ISYM_LEADZ:
+ gfc_conv_intrinsic_leadz (se, expr);
+ break;
+
+ case GFC_ISYM_TRAILZ:
+ gfc_conv_intrinsic_trailz (se, expr);
+ break;
+
case GFC_ISYM_LBOUND:
gfc_conv_intrinsic_bound (se, expr, 0);
break;
break;
case GFC_ISYM_TRANSFER:
- if (se->ss)
+ if (se->ss && se->ss->useflags)
{
- if (se->ss->useflags)
- {
- /* Access the previously obtained result. */
- gfc_conv_tmp_array_ref (se);
- gfc_advance_se_ss_chain (se);
- break;
- }
- else
- gfc_conv_intrinsic_array_transfer (se, expr);
+ /* Access the previously obtained result. */
+ gfc_conv_tmp_array_ref (se);
+ gfc_advance_se_ss_chain (se);
}
else
gfc_conv_intrinsic_transfer (se, expr);
case GFC_ISYM_CHMOD:
case GFC_ISYM_DTIME:
case GFC_ISYM_ETIME:
+ case GFC_ISYM_EXTENDS_TYPE_OF:
case GFC_ISYM_FGET:
case GFC_ISYM_FGETC:
case GFC_ISYM_FNUM:
OSDN Git Service
