/* If an optional argument is itself an optional dummy argument,
check its presence and substitute a null if absent. */
- if (e->expr_type ==EXPR_VARIABLE
+ if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional
&& formal
&& formal->optional)
- gfc_conv_missing_dummy (&argse, e, formal->ts);
+ gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
static tree
build_round_expr (tree arg, tree restype)
{
- tree tmp;
tree argtype;
tree fn;
- bool longlong, convert;
+ bool longlong;
int argprec, resprec;
argtype = TREE_TYPE (arg);
(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;
- }
+ longlong = false;
else if (resprec <= LONG_LONG_TYPE_SIZE)
- {
- longlong = true;
- if (resprec != LONG_LONG_TYPE_SIZE)
- convert = true;
- else
- convert = false;
- }
+ longlong = true;
else
gcc_unreachable ();
else
gcc_unreachable ();
- tmp = build_call_expr (fn, 1, arg);
- if (convert)
- tmp = fold_convert (restype, tmp);
- return tmp;
+ return fold_convert (restype, build_call_expr (fn, 1, arg));
}
{
tree type;
tree itype;
- tree arg;
+ tree arg[2];
tree tmp;
tree cond;
mpfr_t huge;
- int n;
+ int n, nargs;
int kind;
kind = expr->ts.kind;
+ nargs = gfc_intrinsic_argument_list_length (expr);
n = END_BUILTINS;
/* We have builtin functions for some cases. */
/* Evaluate the argument. */
gcc_assert (expr->value.function.actual->expr);
- gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
/* Use a builtin function if one exists. */
if (n != END_BUILTINS)
{
tmp = built_in_decls[n];
- se->expr = build_call_expr (tmp, 1, arg);
+ se->expr = build_call_expr (tmp, 1, arg[0]);
return;
}
/* This code is probably redundant, but we'll keep it lying around just
in case. */
type = gfc_typenode_for_spec (&expr->ts);
- arg = gfc_evaluate_now (arg, &se->pre);
+ arg[0] = gfc_evaluate_now (arg[0], &se->pre);
/* Test if the value is too large to handle sensibly. */
gfc_set_model_kind (kind);
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);
- cond = build2 (LT_EXPR, boolean_type_node, arg, tmp);
+ cond = 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 = build2 (GT_EXPR, boolean_type_node, arg, tmp);
+ tmp = build2 (GT_EXPR, boolean_type_node, arg[0], tmp);
cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
itype = gfc_get_int_type (kind);
- tmp = build_fix_expr (&se->pre, arg, itype, op);
+ tmp = build_fix_expr (&se->pre, arg[0], itype, op);
tmp = convert (type, tmp);
- se->expr = build3 (COND_EXPR, type, cond, tmp, arg);
+ se->expr = build3 (COND_EXPR, type, cond, tmp, arg[0]);
mpfr_clear (huge);
}
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, &expr->where);
+ gfc_trans_runtime_check (cond, &se->pre, &expr->where, gfc_msg_fault);
}
}
/* Get the minimum/maximum value of all the parameters.
minmax (a1, a2, a3, ...)
{
- if (a2 .op. a1 || isnan(a1))
+ mvar = a1;
+ if (a2 .op. mvar || isnan(mvar))
mvar = a2;
- else
- mvar = a1;
if (a3 .op. mvar || isnan(mvar))
mvar = a3;
...
static void
gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
{
- tree limit;
tree tmp;
tree mvar;
tree val;
tree thencase;
- tree elsecase;
tree *args;
tree type;
gfc_actual_arglist *argexpr;
- unsigned int i;
- unsigned int nargs;
+ unsigned int i, nargs;
nargs = gfc_intrinsic_argument_list_length (expr);
args = alloca (sizeof (tree) * nargs);
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);
+ if (TREE_TYPE (args[0]) != type)
+ args[0] = convert (type, args[0]);
/* Only evaluate the argument once. */
- if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
- limit = gfc_evaluate_now (limit, &se->pre);
+ if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
+ args[0] = gfc_evaluate_now (args[0], &se->pre);
mvar = gfc_create_var (type, "M");
- elsecase = build2_v (MODIFY_EXPR, mvar, limit);
+ gfc_add_modify_expr (&se->pre, mvar, args[0]);
for (i = 1, argexpr = argexpr->next; i < nargs; i++)
{
tree cond, isnan;
val = args[i];
/* Handle absent optional arguments by ignoring the comparison. */
- if (i > 0 && argexpr->expr->expr_type == EXPR_VARIABLE
+ if (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),
thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
- tmp = build2 (op, boolean_type_node, convert (type, val), limit);
+ tmp = build2 (op, boolean_type_node, convert (type, val), mvar);
/* 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)))
+ if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
{
- isnan = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, limit);
- tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, isnan);
+ isnan = build_call_expr (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, elsecase);
+ tmp = build3_v (COND_EXPR, tmp, thencase, build_empty_stmt ());
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;
/* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
gcc requires a shift width < BIT_SIZE(I), so we have to catch this
special case. */
- num_bits = build_int_cst (TREE_TYPE (args[0]), TYPE_PRECISION (type));
+ num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
se->expr = fold_build3 (COND_EXPR, type, cond,
/* Returns the starting position of a substring within a string. */
static void
-gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
+ tree function)
{
tree logical4_type_node = gfc_get_logical_type (4);
tree type;
num_args = gfc_intrinsic_argument_list_length (expr);
args = alloca (sizeof (tree) * 5);
- gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+ gfc_conv_intrinsic_function_args (se, expr, args,
+ num_args >= 5 ? 5 : num_args);
type = gfc_typenode_for_spec (&expr->ts);
if (num_args == 4)
args[4] = build_int_cst (logical4_type_node, 0);
else
- {
- gcc_assert (num_args == 5);
- args[4] = convert (logical4_type_node, args[4]);
- }
+ args[4] = convert (logical4_type_node, args[4]);
- fndecl = build_addr (gfor_fndecl_string_index, current_function_decl);
- se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_index)),
- fndecl, 5, args);
+ fndecl = build_addr (function, current_function_decl);
+ se->expr = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
+ 5, args);
se->expr = convert (type, se->expr);
}
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
se->expr = build_call_expr (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);
}
+
+/* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
+ their argument against a constant integer value. */
+
+static void
+gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
+{
+ tree arg;
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ se->expr = fold_build2 (EQ_EXPR, gfc_typenode_for_spec (&expr->ts),
+ arg, build_int_cst (TREE_TYPE (arg), value));
+}
+
+
+
/* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
static void
static void
gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
{
- tree type;
tree args[4];
gfc_conv_intrinsic_function_args (se, expr, args, 4);
se->expr = gfc_build_compare_string (args[0], args[1], args[2], args[3]);
- type = gfc_typenode_for_spec (&expr->ts);
- se->expr = fold_build2 (op, type, se->expr,
- build_int_cst (TREE_TYPE (se->expr), 0));
+ se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
+ build_int_cst (TREE_TYPE (se->expr), 0));
}
/* Generate a call to the adjustl/adjustr library function. */
gfc_se arg2se;
tree tmp2;
tree tmp;
- tree fndecl;
tree nonzero_charlen;
tree nonzero_arraylen;
gfc_ss *ss1, *ss2;
}
else
{
-
/* An array pointer of zero length is not associated if target is
present. */
arg1se.descriptor_only = 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);
- fndecl = gfor_fndecl_associated;
- se->expr = build_call_expr (fndecl, 2, arg1se.expr, arg2se.expr);
+ se->expr = build_call_expr (gfor_fndecl_associated, 2,
+ arg1se.expr, arg2se.expr);
+ se->expr = convert (boolean_type_node, se->expr);
se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
se->expr, nonzero_arraylen);
-
}
/* If target is present zero character length pointers cannot
}
-/* Scan a string for any one of the characters in a set of characters. */
-
-static void
-gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
-{
- tree logical4_type_node = gfc_get_logical_type (4);
- tree type;
- tree fndecl;
- tree *args;
- unsigned int num_args;
-
- num_args = gfc_intrinsic_argument_list_length (expr);
- args = alloca (sizeof (tree) * 5);
-
- gfc_conv_intrinsic_function_args (se, expr, args, num_args);
- type = gfc_typenode_for_spec (&expr->ts);
-
- if (num_args == 4)
- args[4] = build_int_cst (logical4_type_node, 0);
- else
- {
- gcc_assert (num_args == 5);
- args[4] = convert (logical4_type_node, args[4]);
- }
-
- fndecl = build_addr (gfor_fndecl_string_scan, current_function_decl);
- se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_scan)),
- fndecl, 5, args);
- se->expr = convert (type, se->expr);
-}
-
-
-/* Verify that a set of characters contains all the characters in a string
- by identifying the position of the first character in a string of
- characters that does not appear in a given set of characters. */
-
-static void
-gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
-{
- tree logical4_type_node = gfc_get_logical_type (4);
- tree type;
- tree fndecl;
- tree *args;
- unsigned int num_args;
-
- num_args = gfc_intrinsic_argument_list_length (expr);
- args = alloca (sizeof (tree) * 5);
-
- gfc_conv_intrinsic_function_args (se, expr, args, num_args);
- type = gfc_typenode_for_spec (&expr->ts);
-
- if (num_args == 4)
- args[4] = build_int_cst (logical4_type_node, 0);
- else
- {
- gcc_assert (num_args == 5);
- args[4] = convert (logical4_type_node, args[4]);
- }
-
- fndecl = build_addr (gfor_fndecl_string_verify, current_function_decl);
- se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_verify)),
- fndecl, 5, args);
-
- se->expr = convert (type, se->expr);
-}
-
-
/* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
static void
/* Check that NCOPIES is not negative. */
cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
build_int_cst (ncopies_type, 0));
- gfc_trans_runtime_check (cond,
- "Argument NCOPIES of REPEAT intrinsic is negative",
- &se->pre, &expr->where);
+ gfc_trans_runtime_check (cond, &se->pre, &expr->where,
+ "Argument NCOPIES of REPEAT intrinsic is negative "
+ "(its value is %lld)",
+ fold_convert (long_integer_type_node, ncopies));
/* If the source length is zero, any non negative value of NCOPIES
is valid, and nothing happens. */
build_int_cst (size_type_node, 0));
cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
cond);
- gfc_trans_runtime_check (cond,
- "Argument NCOPIES of REPEAT intrinsic is too large",
- &se->pre, &expr->where);
+ gfc_trans_runtime_check (cond, &se->pre, &expr->where,
+ "Argument NCOPIES of REPEAT intrinsic is too large");
+
/* Compute the destination length. */
dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
break;
case GFC_ISYM_SCAN:
- gfc_conv_intrinsic_scan (se, expr);
+ gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_scan);
break;
case GFC_ISYM_VERIFY:
- gfc_conv_intrinsic_verify (se, expr);
+ gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_verify);
break;
case GFC_ISYM_ALLOCATED:
break;
case GFC_ISYM_INDEX:
- gfc_conv_intrinsic_index (se, expr);
+ gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_index);
break;
case GFC_ISYM_IOR:
gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
break;
+ case GFC_ISYM_IS_IOSTAT_END:
+ gfc_conv_has_intvalue (se, expr, LIBERROR_END);
+ break;
+
+ case GFC_ISYM_IS_IOSTAT_EOR:
+ gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
+ break;
+
case GFC_ISYM_ISNAN:
gfc_conv_intrinsic_isnan (se, expr);
break;
case GFC_ISYM_ACCESS:
case GFC_ISYM_CHDIR:
case GFC_ISYM_CHMOD:
+ case GFC_ISYM_DTIME:
case GFC_ISYM_ETIME:
case GFC_ISYM_FGET:
case GFC_ISYM_FGETC:
default:
/* This probably meant someone forgot to add an intrinsic to the above
- list(s) when they implemented it, or something's gone horribly wrong.
- */
- gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
- expr->value.function.name);
+ list(s) when they implemented it, or something's gone horribly
+ wrong. */
+ gcc_unreachable ();
}
}
OSDN Git Service
