/* Intrinsic translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
/* Evaluate the arguments to an intrinsic function. */
+/* FIXME: This function and its callers should be rewritten so that it's
+ not necessary to cons up a list to hold the arguments. */
static tree
gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
- gfc_trans_runtime_check (cond, gfc_msg_fault, &se->pre, NULL);
+ gfc_trans_runtime_check (cond, gfc_msg_fault, &se->pre, &expr->where);
}
}
/* SIGN(A, B) is absolute value of A times sign of B.
The real value versions use library functions to ensure the correct
handling of negative zero. Integer case implemented as:
- SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
+ SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
*/
static void
tree arg;
tree arg2;
tree type;
- tree zero;
- tree testa;
- tree testb;
-
arg = gfc_conv_intrinsic_function_args (se, expr);
if (expr->ts.type == BT_REAL)
return;
}
+ /* Having excluded floating point types, we know we are now dealing
+ with signed integer types. */
arg2 = TREE_VALUE (TREE_CHAIN (arg));
arg = TREE_VALUE (arg);
type = TREE_TYPE (arg);
- zero = gfc_build_const (type, integer_zero_node);
- testa = fold_build2 (GE_EXPR, boolean_type_node, arg, zero);
- testb = fold_build2 (GE_EXPR, boolean_type_node, arg2, zero);
- tmp = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb);
- se->expr = fold_build3 (COND_EXPR, type, tmp,
- build1 (NEGATE_EXPR, type, arg), arg);
+ /* Arg is used multiple times below. */
+ arg = gfc_evaluate_now (arg, &se->pre);
+
+ /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
+ the signs of A and B are the same, and of all ones if they differ. */
+ tmp = fold_build2 (BIT_XOR_EXPR, type, arg, arg2);
+ tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
+ build_int_cst (type, TYPE_PRECISION (type) - 1));
+ tmp = gfc_evaluate_now (tmp, &se->pre);
+
+ /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
+ is all ones (i.e. -1). */
+ se->expr = fold_build2 (BIT_XOR_EXPR, type,
+ fold_build2 (PLUS_EXPR, type, arg, tmp),
+ tmp);
}
/* Free the temporary afterwards, if necessary. */
cond = build2 (GT_EXPR, boolean_type_node, len,
build_int_cst (TREE_TYPE (len), 0));
- arglist = gfc_chainon_list (NULL_TREE, var);
- tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
+ tmp = build_call_expr (gfor_fndecl_internal_free, 1, var);
tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se->post, tmp);
/* Free the temporary afterwards, if necessary. */
cond = build2 (GT_EXPR, boolean_type_node, len,
build_int_cst (TREE_TYPE (len), 0));
- arglist = gfc_chainon_list (NULL_TREE, var);
- tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
+ tmp = build_call_expr (gfor_fndecl_internal_free, 1, var);
tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se->post, tmp);
/* Free the temporary afterwards, if necessary. */
cond = build2 (GT_EXPR, boolean_type_node, len,
build_int_cst (TREE_TYPE (len), 0));
- arglist = gfc_chainon_list (NULL_TREE, var);
- tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
+ tmp = build_call_expr (gfor_fndecl_internal_free, 1, var);
tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se->post, tmp);
limit = convert (type, limit);
/* Only evaluate the argument once. */
if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
- limit = gfc_evaluate_now(limit, &se->pre);
+ limit = gfc_evaluate_now (limit, &se->pre);
mvar = gfc_create_var (type, "M");
elsecase = build2_v (MODIFY_EXPR, mvar, limit);
/* Only evaluate the argument once. */
if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
- val = gfc_evaluate_now(val, &se->pre);
+ val = gfc_evaluate_now (val, &se->pre);
thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
gcc_unreachable ();
}
- /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */
+ /* We start with the most negative possible value for MAXLOC, and the most
+ positive possible value for MINLOC. The most negative possible value is
+ -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);
gfc_add_modify_expr (&se->pre, limit, tmp);
+ if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
+ tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
+ build_int_cst (type, 1));
+
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, arrayss);
gcc_unreachable ();
}
- /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval. */
+ /* We start with the most negative possible value for MAXVAL, and the most
+ positive possible value for MINVAL. The most negative possible value is
+ -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);
+
+ if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
+ tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
+ build_int_cst (type, 1));
+
gfc_add_modify_expr (&se->pre, limit, tmp);
/* Walk the arguments. */
arg2 = TREE_VALUE (arg2);
type = TREE_TYPE (arg);
- mask = build_int_cst (NULL_TREE, -1);
+ mask = build_int_cst (type, -1);
mask = build2 (LSHIFT_EXPR, type, mask, arg3);
mask = build1 (BIT_NOT_EXPR, type, mask);
tree lower;
tree stride;
tree stmt;
- tree args;
gfc_actual_arglist *arg;
gfc_se argse;
gfc_ss *ss;
&& arg->expr->ref->u.ar.type == AR_FULL))
{
tmp = build_fold_addr_expr (argse.expr);
- tmp = gfc_chainon_list (NULL_TREE, tmp);
- source = build_function_call_expr (gfor_fndecl_in_pack, tmp);
+ source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
source = gfc_evaluate_now (source, &argse.pre);
/* Free the temporary. */
gfc_start_block (&block);
tmp = convert (pvoid_type_node, source);
- tmp = gfc_chainon_list (NULL_TREE, tmp);
- tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
+ tmp = build_call_expr (gfor_fndecl_internal_free, 1, tmp);
gfc_add_expr_to_block (&block, tmp);
stmt = gfc_finish_block (&block);
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. */
+ data field. This is already allocated so set callee_alloc.
+ FIXME callee_alloc is not set! */
+
tmp = gfc_typenode_for_spec (&expr->ts);
gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
- info, tmp, false, true, false, false);
+ info, tmp, false, true, false);
/* Use memcpy to do the transfer. */
- tmp = gfc_conv_descriptor_data_get (info->descriptor);
- args = gfc_chainon_list (NULL_TREE, tmp);
- tmp = fold_convert (pvoid_type_node, source);
- args = gfc_chainon_list (args, source);
- args = gfc_chainon_list (args, size_bytes);
- tmp = built_in_decls[BUILT_IN_MEMCPY];
- tmp = build_function_call_expr (tmp, args);
+ tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
+ 3,
+ gfc_conv_descriptor_data_get (info->descriptor),
+ fold_convert (pvoid_type_node, source),
+ size_bytes);
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = info->descriptor;
tree type;
tree ptr;
gfc_ss *ss;
- tree tmpdecl, tmp, args;
+ tree tmpdecl, tmp;
/* Get a pointer to the source. */
arg = expr->value.function.actual;
/* Use memcpy to do the transfer. */
tmp = build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl);
- tmp = fold_convert (pvoid_type_node, tmp);
- args = gfc_chainon_list (NULL_TREE, tmp);
- tmp = fold_convert (pvoid_type_node, ptr);
- args = gfc_chainon_list (args, tmp);
- args = gfc_chainon_list (args, moldsize);
- tmp = built_in_decls[BUILT_IN_MEMCPY];
- tmp = build_function_call_expr (tmp, args);
+ tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+ fold_convert (pvoid_type_node, tmp),
+ fold_convert (pvoid_type_node, ptr),
+ moldsize);
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = tmpdecl;
gfc_se arg2se;
tree tmp2;
tree tmp;
- tree args, fndecl;
+ tree fndecl;
tree nonzero_charlen;
tree nonzero_arraylen;
gfc_ss *ss1, *ss2;
gfc_add_block_to_block (&se->pre, &arg1se.pre);
gfc_add_block_to_block (&se->post, &arg1se.post);
tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
- se->expr = tmp;
+ tmp2 = build2 (NE_EXPR, boolean_type_node, arg1se.expr,
+ null_pointer_node);
+ se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, tmp, tmp2);
}
else
{
/* A pointer to an array, call library function _gfor_associated. */
gcc_assert (ss2 != gfc_ss_terminator);
- args = NULL_TREE;
arg1se.want_pointer = 1;
gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
- args = gfc_chainon_list (args, arg1se.expr);
arg2se.want_pointer = 1;
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);
- args = gfc_chainon_list (args, arg2se.expr);
fndecl = gfor_fndecl_associated;
- se->expr = build_function_call_expr (fndecl, args);
+ se->expr = build_call_expr (fndecl, 2, arg1se.expr, arg2se.expr);
se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
se->expr, nonzero_arraylen);
args = gfc_conv_intrinsic_function_args (se, expr);
args = TREE_VALUE (args);
args = build_fold_addr_expr (args);
- args = tree_cons (NULL_TREE, args, NULL_TREE);
- se->expr = build_function_call_expr (gfor_fndecl_si_kind, args);
+ se->expr = build_call_expr (gfor_fndecl_si_kind, 1, args);
}
/* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
/* Free the temporary afterwards, if necessary. */
cond = build2 (GT_EXPR, boolean_type_node, len,
build_int_cst (TREE_TYPE (len), 0));
- arglist = gfc_chainon_list (NULL_TREE, var);
- tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
+ tmp = build_call_expr (gfor_fndecl_internal_free, 1, var);
tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se->post, tmp);
tree tmp;
tree len;
tree args;
- tree arglist;
tree ncopies;
tree var;
tree type;
+ tree cond;
args = gfc_conv_intrinsic_function_args (se, expr);
len = TREE_VALUE (args);
tmp = gfc_advance_chain (args, 2);
ncopies = TREE_VALUE (tmp);
+
+ /* Check that ncopies is not negative. */
+ ncopies = gfc_evaluate_now (ncopies, &se->pre);
+ cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
+ build_int_cst (TREE_TYPE (ncopies), 0));
+ gfc_trans_runtime_check (cond,
+ "Argument NCOPIES of REPEAT intrinsic is negative",
+ &se->pre, &expr->where);
+
+ /* Compute the destination length. */
len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies);
type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
- arglist = NULL_TREE;
- arglist = gfc_chainon_list (arglist, var);
- arglist = chainon (arglist, args);
- tmp = build_function_call_expr (gfor_fndecl_string_repeat, arglist);
+ /* Create the argument list and generate the function call. */
+ tmp = build_call_expr (gfor_fndecl_string_repeat, 4, var,
+ TREE_VALUE (args),
+ TREE_VALUE (TREE_CHAIN (args)), ncopies);
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = var;
/* Call the library function. This always returns an INTEGER(4). */
fndecl = gfor_fndecl_iargc;
- tmp = build_function_call_expr (fndecl, NULL_TREE);
+ tmp = build_call_expr (fndecl, 0);
/* Convert it to the required type. */
type = gfc_typenode_for_spec (&expr->ts);
OSDN Git Service
