GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
+#include "tm.h"
#include "tree.h"
#include "ggc.h"
#include "toplev.h"
e = actual->expr;
/* Skip omitted optional arguments. */
if (!e)
- continue;
+ {
+ --curr_arg;
+ continue;
+ }
/* Evaluate the parameter. This will substitute scalarized
references automatically. */
gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
{
tree type;
- tree arg;
+ tree *args;
+ int nargs;
- /* Evaluate the argument. */
+ nargs = gfc_intrinsic_argument_list_length (expr);
+ args = alloca (sizeof (tree) * nargs);
+
+ /* Evaluate all the arguments passed. Whilst we're only interested in the
+ first one here, there are other parts of the front-end that assume this
+ and will trigger an ICE if it's not the case. */
type = gfc_typenode_for_spec (&expr->ts);
gcc_assert (expr->value.function.actual->expr);
- gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ gfc_conv_intrinsic_function_args (se, expr, args, nargs);
/* Conversion from complex to non-complex involves taking the real
component of the value. */
- if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
+ if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
&& expr->ts.type != BT_COMPLEX)
{
tree artype;
- artype = TREE_TYPE (TREE_TYPE (arg));
- arg = build1 (REALPART_EXPR, artype, arg);
+ artype = TREE_TYPE (TREE_TYPE (args[0]));
+ args[0] = build1 (REALPART_EXPR, artype, args[0]);
}
- se->expr = convert (type, arg);
+ se->expr = convert (type, args[0]);
}
/* This is needed because the gcc backend only implements
}
-/* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
- NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)). */
+/* Round to nearest integer, away from zero. */
static tree
-build_round_expr (stmtblock_t * pblock, tree arg, tree type)
+build_round_expr (tree arg, tree restype)
{
tree tmp;
- tree cond;
- tree neg;
- tree pos;
tree argtype;
- REAL_VALUE_TYPE r;
+ tree fn;
+ bool longlong, convert;
+ int argprec, resprec;
argtype = TREE_TYPE (arg);
- arg = gfc_evaluate_now (arg, pblock);
+ argprec = TYPE_PRECISION (argtype);
+ resprec = TYPE_PRECISION (restype);
- real_from_string (&r, "0.5");
- pos = build_real (argtype, r);
-
- real_from_string (&r, "-0.5");
- neg = build_real (argtype, r);
+ /* Depending on the type of the result, choose the long int intrinsic
+ (lround family) or long long intrinsic (llround). We might also
+ need to convert the result afterwards. */
+ if (resprec <= LONG_TYPE_SIZE)
+ {
+ longlong = false;
+ if (resprec != LONG_TYPE_SIZE)
+ convert = true;
+ else
+ convert = false;
+ }
+ else if (resprec <= LONG_LONG_TYPE_SIZE)
+ {
+ longlong = true;
+ if (resprec != LONG_LONG_TYPE_SIZE)
+ convert = true;
+ else
+ convert = false;
+ }
+ else
+ gcc_unreachable ();
- tmp = gfc_build_const (argtype, integer_zero_node);
- cond = fold_build2 (GT_EXPR, boolean_type_node, arg, tmp);
+ /* Now, depending on the argument type, we choose between intrinsics. */
+ if (argprec == TYPE_PRECISION (float_type_node))
+ fn = built_in_decls[longlong ? BUILT_IN_LLROUNDF : BUILT_IN_LROUNDF];
+ else if (argprec == TYPE_PRECISION (double_type_node))
+ fn = built_in_decls[longlong ? BUILT_IN_LLROUND : BUILT_IN_LROUND];
+ else if (argprec == TYPE_PRECISION (long_double_type_node))
+ fn = built_in_decls[longlong ? BUILT_IN_LLROUNDL : BUILT_IN_LROUNDL];
+ else
+ gcc_unreachable ();
- tmp = fold_build3 (COND_EXPR, argtype, cond, pos, neg);
- tmp = fold_build2 (PLUS_EXPR, argtype, arg, tmp);
- return fold_build1 (FIX_TRUNC_EXPR, type, tmp);
+ tmp = build_call_expr (fn, 1, arg);
+ if (convert)
+ tmp = fold_convert (restype, tmp);
+ return tmp;
}
break;
case RND_ROUND:
- return build_round_expr (pblock, arg, type);
+ return build_round_expr (arg, type);
+ break;
- default:
- gcc_assert (op == RND_TRUNC);
+ case RND_TRUNC:
return build1 (FIX_TRUNC_EXPR, type, arg);
+ break;
+
+ default:
+ gcc_unreachable ();
}
}
gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
{
tree type;
- tree arg;
+ tree *args;
+ int nargs;
- /* Evaluate the argument. */
+ nargs = gfc_intrinsic_argument_list_length (expr);
+ args = alloca (sizeof (tree) * nargs);
+
+ /* Evaluate the argument, we process all arguments even though we only
+ use the first one for code generation purposes. */
type = gfc_typenode_for_spec (&expr->ts);
gcc_assert (expr->value.function.actual->expr);
- gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ gfc_conv_intrinsic_function_args (se, expr, args, nargs);
- if (TREE_CODE (TREE_TYPE (arg)) == INTEGER_TYPE)
+ if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
{
/* Conversion to a different integer kind. */
- se->expr = convert (type, arg);
+ se->expr = convert (type, args[0]);
}
else
{
/* Conversion from complex to non-complex involves taking the real
component of the value. */
- if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
+ if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
&& expr->ts.type != BT_COMPLEX)
{
tree artype;
- artype = TREE_TYPE (TREE_TYPE (arg));
- arg = build1 (REALPART_EXPR, artype, arg);
+ artype = TREE_TYPE (TREE_TYPE (args[0]));
+ args[0] = build1 (REALPART_EXPR, artype, args[0]);
}
- se->expr = build_fix_expr (&se->pre, arg, type, op);
+ se->expr = build_fix_expr (&se->pre, args[0], type, op);
}
}
/* Generate code for EXPONENT(X) intrinsic function. */
static void
-gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
{
- tree arg, fndecl;
+ tree arg, fndecl, type;
gfc_expr *a1;
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
gcc_unreachable ();
}
- se->expr = build_call_expr (fndecl, 1, arg);
+ /* Convert it to the required type. */
+ type = gfc_typenode_for_spec (&expr->ts);
+ se->expr = fold_convert (type, build_call_expr (fndecl, 1, arg));
}
/* Evaluate a single upper or lower bound. */
/* Get the minimum/maximum value of all the parameters.
minmax (a1, a2, a3, ...)
{
- if (a2 .op. a1)
+ if (a2 .op. a1 || isnan(a1))
mvar = a2;
else
mvar = a1;
- if (a3 .op. mvar)
+ if (a3 .op. mvar || isnan(mvar))
mvar = a3;
...
return mvar
tree val;
tree thencase;
tree elsecase;
- tree type;
tree *args;
- unsigned int num_args;
+ tree type;
+ gfc_actual_arglist *argexpr;
unsigned int i;
+ unsigned int nargs;
- num_args = gfc_intrinsic_argument_list_length (expr);
- args = alloca (sizeof (tree) * num_args);
+ nargs = gfc_intrinsic_argument_list_length (expr);
+ args = alloca (sizeof (tree) * nargs);
- gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+ gfc_conv_intrinsic_function_args (se, expr, args, nargs);
type = gfc_typenode_for_spec (&expr->ts);
+ /* The first and second arguments should be present, if they are
+ optional dummy arguments. */
+ argexpr = expr->value.function.actual;
+ if (argexpr->expr->expr_type == EXPR_VARIABLE
+ && argexpr->expr->symtree->n.sym->attr.optional
+ && TREE_CODE (args[0]) == INDIRECT_REF)
+ {
+ /* Check the first argument. */
+ tree cond;
+ char *msg;
+
+ asprintf (&msg, "First argument of '%s' intrinsic should be present",
+ expr->symtree->n.sym->name);
+ cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (args[0], 0),
+ build_int_cst (TREE_TYPE (TREE_OPERAND (args[0], 0)), 0));
+ gfc_trans_runtime_check (cond, msg, &se->pre, &expr->where);
+ gfc_free (msg);
+ }
+
+ if (argexpr->next->expr->expr_type == EXPR_VARIABLE
+ && argexpr->next->expr->symtree->n.sym->attr.optional
+ && TREE_CODE (args[1]) == INDIRECT_REF)
+ {
+ /* Check the second argument. */
+ tree cond;
+ char *msg;
+
+ asprintf (&msg, "Second argument of '%s' intrinsic should be present",
+ expr->symtree->n.sym->name);
+ cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (args[1], 0),
+ build_int_cst (TREE_TYPE (TREE_OPERAND (args[1], 0)), 0));
+ gfc_trans_runtime_check (cond, msg, &se->pre, &expr->where);
+ gfc_free (msg);
+ }
+
limit = args[0];
if (TREE_TYPE (limit) != type)
limit = convert (type, limit);
mvar = gfc_create_var (type, "M");
elsecase = build2_v (MODIFY_EXPR, mvar, limit);
- for (i = 1; i < num_args; i++)
+ for (i = 1, argexpr = argexpr->next; i < nargs; i++)
{
- val = args[i];
- if (TREE_TYPE (val) != type)
- val = convert (type, val);
+ tree cond, isnan;
+
+ val = args[i];
- /* Only evaluate the argument once. */
- if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
- val = gfc_evaluate_now (val, &se->pre);
+ /* Handle absent optional arguments by ignoring the comparison. */
+ if (i > 0 && argexpr->expr->expr_type == EXPR_VARIABLE
+ && argexpr->expr->symtree->n.sym->attr.optional
+ && TREE_CODE (val) == INDIRECT_REF)
+ cond = build2 (NE_EXPR, boolean_type_node, TREE_OPERAND (val, 0),
+ build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
+ else
+ {
+ cond = NULL_TREE;
+
+ /* Only evaluate the argument once. */
+ if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
+ val = gfc_evaluate_now (val, &se->pre);
+ }
thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
- tmp = build2 (op, boolean_type_node, val, limit);
+ tmp = build2 (op, boolean_type_node, convert (type, val), limit);
+
+ /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
+ __builtin_isnan might be made dependent on that module being loaded,
+ to help performance of programs that don't rely on IEEE semantics. */
+ if (FLOAT_TYPE_P (TREE_TYPE (limit)))
+ {
+ isnan = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, limit);
+ tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, isnan);
+ }
tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
+
+ if (cond != NULL_TREE)
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+
gfc_add_expr_to_block (&se->pre, tmp);
elsecase = build_empty_stmt ();
limit = mvar;
+ argexpr = argexpr->next;
}
se->expr = mvar;
}
tree tmp;
tree elsetmp;
tree ifbody;
+ tree offset;
gfc_loopinfo loop;
gfc_actual_arglist *actual;
gfc_ss *arrayss;
/* Initialize the result. */
pos = gfc_create_var (gfc_array_index_type, "pos");
+ offset = gfc_create_var (gfc_array_index_type, "offset");
type = gfc_typenode_for_spec (&expr->ts);
/* Walk the arguments. */
/* 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. */
+ 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);
/* Assign the value to the limit... */
gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
- /* Remember where we are. */
- gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]);
+ /* Remember where we are. An offset must be added to the loop
+ counter to obtain the required position. */
+ if (loop.temp_dim)
+ tmp = build_int_cst (gfc_array_index_type, 1);
+ else
+ tmp =fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, loop.from[0]);
+ gfc_add_modify_expr (&block, offset, tmp);
+
+ tmp = build2 (PLUS_EXPR, TREE_TYPE (pos),
+ loop.loopvar[0], offset);
+ gfc_add_modify_expr (&ifblock, pos, tmp);
ifbody = gfc_finish_block (&ifblock);
- /* If it is a more extreme value or pos is still zero. */
+ /* If it is a more extreme value or pos is still zero and the value
+ equal to the limit. */
+ tmp = build2 (TRUTH_AND_EXPR, boolean_type_node,
+ build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node),
+ build2 (EQ_EXPR, boolean_type_node, arrayse.expr, limit));
tmp = build2 (TRUTH_OR_EXPR, boolean_type_node,
- build2 (op, boolean_type_node, arrayse.expr, limit),
- build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node));
+ 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);
}
gfc_cleanup_loop (&loop);
- /* Return a value in the range 1..SIZE(array). */
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0],
- gfc_index_one_node);
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp);
- /* And convert to the required type. */
- se->expr = convert (type, tmp);
+ se->expr = convert (type, pos);
}
static void
/* 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. */
+ possible value is HUGE in both cases. */
if (op == GT_EXPR)
tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
build_int_cst (type, 0), tmp);
}
+
/* Circular shift. AKA rotate or barrel shift. */
+
static void
gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
{
}
+/* Intrinsic ISNAN calls __builtin_isnan. */
+
+static void
+gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * 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 = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
+}
+
/* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
static void
/* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
static void
-gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
{
- tree arg;
+ tree arg, type;
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
- arg = build_fold_addr_expr (arg);
+
+ /* The argument to SELECTED_INT_KIND is INTEGER(4). */
+ type = gfc_get_int_type (4);
+ arg = build_fold_addr_expr (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 = fold_convert (type, se->expr);
}
+
/* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
static void
-gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
{
gfc_actual_arglist *actual;
- tree args;
+ tree args, type;
gfc_se argse;
args = NULL_TREE;
if (actual->expr == NULL)
argse.expr = null_pointer_node;
else
- gfc_conv_expr_reference (&argse, actual->expr);
+ {
+ gfc_typespec ts;
+ if (actual->expr->ts.kind != gfc_c_int_kind)
+ {
+ /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_c_int_kind;
+ gfc_convert_type (actual->expr, &ts, 2);
+ }
+ gfc_conv_expr_reference (&argse, actual->expr);
+ }
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
args = gfc_chainon_list (args, argse.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 = fold_convert (type, se->expr);
}
&se->pre, &expr->where);
/* Compute the destination length. */
- dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node, slen, ncopies);
+ 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);
dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
gfc_add_expr_to_block (&body, tmp);
/* Call memmove (dest + (i*slen), src, slen). */
- tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node, slen,
+ tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
+ fold_convert (gfc_charlen_type_node, slen),
fold_convert (gfc_charlen_type_node, count));
- tmp = fold_build2 (PLUS_EXPR, pchar_type_node, dest,
- fold_convert (pchar_type_node, tmp));
+ tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node,
+ fold_convert (pchar_type_node, dest),
+ fold_convert (sizetype, tmp));
tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
tmp, src, slen);
gfc_add_expr_to_block (&body, tmp);
gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
break;
+ case GFC_ISYM_ISNAN:
+ gfc_conv_intrinsic_isnan (se, expr);
+ break;
+
case GFC_ISYM_LSHIFT:
gfc_conv_intrinsic_rlshift (se, expr, 0);
break;
OSDN Git Service
