/* Intrinsic translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#include "config.h"
#include "system.h"
#include "coretypes.h"
+#include "tm.h"
#include "tree.h"
#include "ggc.h"
#include "toplev.h"
true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
-#define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
- { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
- END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
- true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
- NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
-
-#define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
+#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
{ GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
/* Functions built into gcc itself. */
#include "mathbuiltins.def"
- /* Functions in libm. */
- /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
- pattern for other mathbuiltins.def entries. At present we have no
- optimizations for this in the common sources. */
- LIBM_FUNCTION (SCALE, "scalbn", false),
-
/* Functions in libgfortran. */
- LIBF_FUNCTION (FRACTION, "fraction", false),
- LIBF_FUNCTION (NEAREST, "nearest", false),
- LIBF_FUNCTION (RRSPACING, "rrspacing", false),
- LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
- LIBF_FUNCTION (SPACING, "spacing", false),
+ LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
/* End the list. */
- LIBF_FUNCTION (NONE, NULL, false)
+ LIB_FUNCTION (NONE, NULL, false)
+
};
+#undef LIB_FUNCTION
#undef DEFINE_MATH_BUILTIN
#undef DEFINE_MATH_BUILTIN_C
-#undef LIBM_FUNCTION
-#undef LIBF_FUNCTION
/* Structure for storing components of a floating number to be used by
elemental functions to manipulate reals. */
/* 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);
gcc_assert (expr->value.function.actual->expr);
gfc_conv_intrinsic_function_args (se, expr, args, nargs);
+ /* Conversion between character kinds involves a call to a library
+ function. */
+ if (expr->ts.type == BT_CHARACTER)
+ {
+ tree fndecl, var, addr, tmp;
+
+ if (expr->ts.kind == 1
+ && expr->value.function.actual->expr->ts.kind == 4)
+ fndecl = gfor_fndecl_convert_char4_to_char1;
+ else if (expr->ts.kind == 4
+ && expr->value.function.actual->expr->ts.kind == 1)
+ fndecl = gfor_fndecl_convert_char1_to_char4;
+ else
+ gcc_unreachable ();
+
+ /* Create the variable storing the converted value. */
+ type = gfc_get_pchar_type (expr->ts.kind);
+ var = gfc_create_var (type, "str");
+ addr = gfc_build_addr_expr (build_pointer_type (type), var);
+
+ /* Call the library function that will perform the conversion. */
+ gcc_assert (nargs >= 2);
+ tmp = build_call_expr (fndecl, 3, addr, args[0], args[1]);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Free the temporary afterwards. */
+ tmp = gfc_call_free (var);
+ gfc_add_expr_to_block (&se->post, tmp);
+
+ se->expr = var;
+ se->string_length = args[0];
+
+ return;
+ }
+
/* Conversion from complex to non-complex involves taking the real
component of the value. */
if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
tree artype;
artype = TREE_TYPE (TREE_TYPE (args[0]));
- args[0] = build1 (REALPART_EXPR, artype, args[0]);
+ args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
}
se->expr = convert (type, args[0]);
intval = gfc_evaluate_now (intval, pblock);
tmp = convert (argtype, intval);
- cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
+ cond = fold_build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
- tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
- build_int_cst (type, 1));
- tmp = build3 (COND_EXPR, type, cond, intval, tmp);
+ tmp = fold_build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
+ build_int_cst (type, 1));
+ tmp = fold_build3 (COND_EXPR, type, cond, intval, tmp);
return tmp;
}
-/* 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;
+ int argprec, resprec;
argtype = TREE_TYPE (arg);
- arg = gfc_evaluate_now (arg, pblock);
-
- real_from_string (&r, "0.5");
- pos = build_real (argtype, r);
-
- real_from_string (&r, "-0.5");
- neg = build_real (argtype, r);
+ argprec = TYPE_PRECISION (argtype);
+ resprec = TYPE_PRECISION (restype);
+
+ /* 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;
+ else if (resprec <= LONG_LONG_TYPE_SIZE)
+ longlong = true;
+ 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);
+ return fold_convert (restype, build_call_expr (fn, 1, arg));
}
break;
case RND_ROUND:
- return build_round_expr (pblock, arg, type);
+ return build_round_expr (arg, type);
+ break;
+
+ case RND_TRUNC:
+ return fold_build1 (FIX_TRUNC_EXPR, type, arg);
+ break;
default:
- gcc_assert (op == RND_TRUNC);
- return build1 (FIX_TRUNC_EXPR, type, arg);
+ gcc_unreachable ();
}
}
{
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 = 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 = build2 (GT_EXPR, boolean_type_node, arg, tmp);
- cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
+ 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);
- 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 = fold_build3 (COND_EXPR, type, cond, tmp, arg[0]);
mpfr_clear (huge);
}
tree artype;
artype = TREE_TYPE (TREE_TYPE (args[0]));
- args[0] = build1 (REALPART_EXPR, artype, args[0]);
+ args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
}
se->expr = build_fix_expr (&se->pre, args[0], type, op);
tree arg;
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
- se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
+ se->expr = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
}
tree arg;
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
- se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
+ se->expr = fold_build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
}
se->expr = build_call_array (rettype, fndecl, num_args, args);
}
-/* Generate code for EXPONENT(X) intrinsic function. */
+/* The EXPONENT(s) intrinsic function is translated into
+ int ret;
+ frexp (s, &ret);
+ return ret;
+ */
static void
gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
{
- tree arg, fndecl, type;
- gfc_expr *a1;
-
- gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ tree arg, type, res, tmp;
+ int frexp;
- a1 = expr->value.function.actual->expr;
- switch (a1->ts.kind)
+ switch (expr->value.function.actual->expr->ts.kind)
{
case 4:
- fndecl = gfor_fndecl_math_exponent4;
+ frexp = BUILT_IN_FREXPF;
break;
case 8:
- fndecl = gfor_fndecl_math_exponent8;
+ frexp = BUILT_IN_FREXP;
break;
case 10:
- fndecl = gfor_fndecl_math_exponent10;
- break;
case 16:
- fndecl = gfor_fndecl_math_exponent16;
+ frexp = BUILT_IN_FREXPL;
break;
default:
gcc_unreachable ();
}
- /* Convert it to the required type. */
+ 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));
+ gfc_add_expr_to_block (&se->pre, tmp);
+
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = fold_convert (type, build_call_expr (fndecl, 1, arg));
+ se->expr = fold_convert (type, res);
}
/* Evaluate a single upper or lower bound. */
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);
}
}
size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
gfc_index_one_node);
+ se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
+ gfc_index_zero_node);
}
else
se->expr = gfc_index_one_node;
{
case BT_INTEGER:
case BT_REAL:
- se->expr = build1 (ABS_EXPR, TREE_TYPE (arg), arg);
+ se->expr = fold_build1 (ABS_EXPR, TREE_TYPE (arg), arg);
break;
case BT_COMPLEX:
imag = convert (TREE_TYPE (type), args[1]);
else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
{
- imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])), args[0]);
+ imag = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])),
+ args[0]);
imag = convert (TREE_TYPE (type), imag);
}
else
type = TREE_TYPE (args[0]);
if (modulo)
- se->expr = build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
+ se->expr = fold_build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
else
- se->expr = build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
+ se->expr = fold_build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
break;
case BT_REAL:
{
tree zero = gfc_build_const (type, integer_zero_node);
tmp = gfc_evaluate_now (se->expr, &se->pre);
- test = build2 (LT_EXPR, boolean_type_node, args[0], zero);
- test2 = build2 (LT_EXPR, boolean_type_node, args[1], zero);
- test2 = build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
- test = build2 (NE_EXPR, boolean_type_node, tmp, zero);
- test = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
+ test = fold_build2 (LT_EXPR, boolean_type_node, args[0], zero);
+ test2 = fold_build2 (LT_EXPR, boolean_type_node, args[1], zero);
+ test2 = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
+ test = fold_build2 (NE_EXPR, boolean_type_node, tmp, zero);
+ test = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
test = gfc_evaluate_now (test, &se->pre);
- se->expr = build3 (COND_EXPR, type, test,
- build2 (PLUS_EXPR, type, tmp, args[1]), tmp);
+ se->expr = fold_build3 (COND_EXPR, type, test,
+ fold_build2 (PLUS_EXPR, type, tmp, args[1]),
+ tmp);
return;
}
/* If we do not have a built_in fmod, the calculation is going to
have to be done longhand. */
- tmp = build2 (RDIV_EXPR, type, args[0], args[1]);
+ tmp = fold_build2 (RDIV_EXPR, type, args[0], args[1]);
/* Test if the value is too large to handle sensibly. */
gfc_set_model_kind (expr->ts.kind);
}
mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
- test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
+ 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 = build2 (GT_EXPR, boolean_type_node, tmp, test);
- test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
+ test = fold_build2 (GT_EXPR, boolean_type_node, tmp, test);
+ test2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
itype = gfc_get_int_type (ikind);
if (modulo)
else
tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
tmp = convert (type, tmp);
- tmp = build3 (COND_EXPR, type, test2, tmp, args[0]);
- tmp = build2 (MULT_EXPR, type, tmp, args[1]);
- se->expr = build2 (MINUS_EXPR, type, args[0], tmp);
+ tmp = fold_build3 (COND_EXPR, type, test2, tmp, args[0]);
+ tmp = fold_build2 (MULT_EXPR, type, tmp, args[1]);
+ se->expr = fold_build2 (MINUS_EXPR, type, args[0], tmp);
mpfr_clear (huge);
break;
gfc_conv_intrinsic_function_args (se, expr, args, 2);
type = TREE_TYPE (args[0]);
- val = build2 (MINUS_EXPR, type, args[0], args[1]);
+ val = fold_build2 (MINUS_EXPR, type, args[0], args[1]);
val = gfc_evaluate_now (val, &se->pre);
zero = gfc_build_const (type, integer_zero_node);
- tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
- se->expr = build3 (COND_EXPR, type, tmp, zero, val);
+ tmp = fold_build2 (LE_EXPR, boolean_type_node, val, zero);
+ se->expr = fold_build3 (COND_EXPR, type, tmp, zero, val);
}
type = gfc_typenode_for_spec (&expr->ts);
args[0] = convert (type, args[0]);
args[1] = convert (type, args[1]);
- se->expr = build2 (MULT_EXPR, type, args[0], args[1]);
+ se->expr = fold_build2 (MULT_EXPR, type, args[0], args[1]);
}
static void
gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
{
- tree arg;
+ tree arg[2];
tree var;
tree type;
+ unsigned int num_args;
- gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ num_args = gfc_intrinsic_argument_list_length (expr);
+ gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
- /* We currently don't support character types != 1. */
- gcc_assert (expr->ts.kind == 1);
- type = gfc_character1_type_node;
+ type = gfc_get_char_type (expr->ts.kind);
var = gfc_create_var (type, "char");
- arg = convert (type, arg);
- gfc_add_modify_expr (&se->pre, var, arg);
+ arg[0] = fold_build1 (NOP_EXPR, type, arg[0]);
+ gfc_add_modify_expr (&se->pre, var, arg[0]);
se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
se->string_length = integer_one_node;
}
tree var;
tree len;
tree tmp;
- tree type;
tree cond;
- tree gfc_int8_type_node = gfc_get_int_type (8);
tree fndecl;
tree *args;
unsigned int num_args;
num_args = gfc_intrinsic_argument_list_length (expr) + 2;
args = alloca (sizeof (tree) * num_args);
- type = build_pointer_type (gfc_character1_type_node);
- var = gfc_create_var (type, "pstr");
- len = gfc_create_var (gfc_int8_type_node, "len");
+ var = gfc_create_var (pchar_type_node, "pstr");
+ 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);
gfc_add_expr_to_block (&se->pre, tmp);
/* Free the temporary afterwards, if necessary. */
- cond = build2 (GT_EXPR, boolean_type_node, len,
- build_int_cst (TREE_TYPE (len), 0));
+ 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 ());
gfc_add_expr_to_block (&se->post, tmp);
tree var;
tree len;
tree tmp;
- tree type;
tree cond;
- tree gfc_int4_type_node = gfc_get_int_type (4);
tree fndecl;
tree *args;
unsigned int num_args;
num_args = gfc_intrinsic_argument_list_length (expr) + 2;
args = alloca (sizeof (tree) * num_args);
- type = build_pointer_type (gfc_character1_type_node);
- var = gfc_create_var (type, "pstr");
- len = gfc_create_var (gfc_int4_type_node, "len");
+ var = gfc_create_var (pchar_type_node, "pstr");
+ 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);
gfc_add_expr_to_block (&se->pre, tmp);
/* Free the temporary afterwards, if necessary. */
- cond = build2 (GT_EXPR, boolean_type_node, len,
- build_int_cst (TREE_TYPE (len), 0));
+ 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 ());
gfc_add_expr_to_block (&se->post, tmp);
tree var;
tree len;
tree tmp;
- tree type;
tree cond;
tree fndecl;
- tree gfc_int4_type_node = gfc_get_int_type (4);
tree *args;
unsigned int num_args;
num_args = gfc_intrinsic_argument_list_length (expr) + 2;
args = alloca (sizeof (tree) * num_args);
- type = build_pointer_type (gfc_character1_type_node);
- var = gfc_create_var (type, "pstr");
- len = gfc_create_var (gfc_int4_type_node, "len");
+ var = gfc_create_var (pchar_type_node, "pstr");
+ 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);
gfc_add_expr_to_block (&se->pre, tmp);
/* Free the temporary afterwards, if necessary. */
- cond = build2 (GT_EXPR, boolean_type_node, len,
- build_int_cst (TREE_TYPE (len), 0));
+ 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 ());
gfc_add_expr_to_block (&se->post, tmp);
/* 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),
- build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
+ cond = fold_build2
+ (NE_EXPR, boolean_type_node, TREE_OPERAND (val, 0),
+ build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
else
{
cond = NULL_TREE;
thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
- tmp = build2 (op, boolean_type_node, convert (type, val), limit);
+ tmp = fold_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;
}
+/* Generate library calls for MIN and MAX intrinsics for character
+ variables. */
+static void
+gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
+{
+ tree *args;
+ tree var, len, fndecl, tmp, cond, function;
+ unsigned int nargs;
+
+ nargs = gfc_intrinsic_argument_list_length (expr);
+ args = alloca (sizeof (tree) * (nargs + 4));
+ gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
+
+ /* Create the result variables. */
+ len = gfc_create_var (gfc_charlen_type_node, "len");
+ args[0] = build_fold_addr_expr (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);
+ args[3] = build_int_cst (NULL_TREE, nargs / 2);
+
+ if (expr->ts.kind == 1)
+ function = gfor_fndecl_string_minmax;
+ else if (expr->ts.kind == 4)
+ function = gfor_fndecl_string_minmax_char4;
+ else
+ gcc_unreachable ();
+
+ /* Make the function call. */
+ fndecl = build_addr (function, current_function_decl);
+ tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
+ nargs + 4, args);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Free the temporary afterwards, if necessary. */
+ 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 ());
+ gfc_add_expr_to_block (&se->post, tmp);
+
+ se->expr = var;
+ se->string_length = len;
+}
+
+
/* Create a symbol node for this intrinsic. The symbol from the frontend
has the generic name. */
/* Generate the loop body. */
gfc_start_scalarized_body (&loop, &body);
- tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
- build_int_cst (TREE_TYPE (resvar), 1));
+ tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (resvar),
+ resvar, build_int_cst (TREE_TYPE (resvar), 1));
tmp = build2_v (MODIFY_EXPR, resvar, tmp);
gfc_init_se (&arrayse, NULL);
gfc_conv_expr_val (&arrayse, arrayexpr);
gfc_add_block_to_block (&block, &arrayse.pre);
- tmp = build2 (op, type, resvar, arrayse.expr);
+ tmp = fold_build2 (op, type, resvar, arrayse.expr);
gfc_add_modify_expr (&block, resvar, tmp);
gfc_add_block_to_block (&block, &arrayse.post);
arrayse1.ss = arrayss1;
gfc_conv_expr_val (&arrayse1, arrayexpr1);
if (expr->ts.type == BT_COMPLEX)
- arrayse1.expr = build1 (CONJ_EXPR, type, arrayse1.expr);
+ arrayse1.expr = fold_build1 (CONJ_EXPR, type, arrayse1.expr);
gfc_add_block_to_block (&block, &arrayse1.pre);
/* Make the tree expression for array2. */
/* Do the actual product and sum. */
if (expr->ts.type == BT_LOGICAL)
{
- tmp = build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
- tmp = build2 (TRUTH_OR_EXPR, type, resvar, tmp);
+ tmp = fold_build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
+ tmp = fold_build2 (TRUTH_OR_EXPR, type, resvar, tmp);
}
else
{
- tmp = build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
- tmp = build2 (PLUS_EXPR, type, resvar, tmp);
+ tmp = fold_build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
+ tmp = fold_build2 (PLUS_EXPR, type, resvar, tmp);
}
gfc_add_modify_expr (&block, resvar, 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));
+ tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
+ build_int_cst (type, 1));
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
/* 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);
+ if (loop.from[0])
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, loop.from[0]);
else
- tmp =fold_build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, loop.from[0]);
+ tmp = build_int_cst (gfc_array_index_type, 1);
+
gfc_add_modify_expr (&block, offset, tmp);
- tmp = build2 (PLUS_EXPR, TREE_TYPE (pos),
- loop.loopvar[0], offset);
+ tmp = fold_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 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), tmp);
+ 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);
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));
+ tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp),
+ tmp, build_int_cst (type, 1));
gfc_add_modify_expr (&se->pre, limit, tmp);
ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
/* If it is a more extreme value. */
- tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
+ 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);
gfc_conv_intrinsic_function_args (se, expr, args, 2);
type = TREE_TYPE (args[0]);
- tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
- tmp = build2 (BIT_AND_EXPR, type, args[0], tmp);
+ tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
+ tmp = fold_build2 (BIT_AND_EXPR, type, args[0], tmp);
tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
build_int_cst (type, 0));
type = gfc_typenode_for_spec (&expr->ts);
tree arg;
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
- se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
+ se->expr = fold_build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
}
/* Set or clear a single bit. */
type = TREE_TYPE (args[0]);
mask = build_int_cst (type, -1);
- mask = build2 (LSHIFT_EXPR, type, mask, args[2]);
- mask = build1 (BIT_NOT_EXPR, type, mask);
+ mask = fold_build2 (LSHIFT_EXPR, type, mask, args[2]);
+ mask = fold_build1 (BIT_NOT_EXPR, type, mask);
- tmp = build2 (RSHIFT_EXPR, type, args[0], args[1]);
+ tmp = fold_build2 (RSHIFT_EXPR, type, args[0], args[1]);
se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
}
The standard doesn't define the case of shifting negative
numbers, and we try to be compatible with other compilers, most
notably g77, here. */
- rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype,
- convert (utype, args[0]), width));
+ rshift = fold_convert (type, fold_build2 (RSHIFT_EXPR, utype,
+ convert (utype, args[0]), width));
tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
build_int_cst (TREE_TYPE (args[1]), 0));
/* 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,
static void
gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
{
- tree args[2];
- tree type;
+ int kind = expr->value.function.actual->expr->ts.kind;
+ tree args[2], type, fndecl;
gfc_conv_intrinsic_function_args (se, expr, args, 2);
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = build_call_expr (gfor_fndecl_string_len_trim, 2, args[0], args[1]);
+
+ if (kind == 1)
+ fndecl = gfor_fndecl_string_len_trim;
+ else if (kind == 4)
+ fndecl = gfor_fndecl_string_len_trim_char4;
+ else
+ gcc_unreachable ();
+
+ se->expr = build_call_expr (fndecl, 2, args[0], args[1]);
se->expr = convert (type, se->expr);
}
/* 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);
}
static void
gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
{
- tree args[2];
- tree type;
+ tree args[2], type, pchartype;
gfc_conv_intrinsic_function_args (se, expr, args, 2);
gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
- args[1] = build1 (NOP_EXPR, pchar_type_node, args[1]);
+ pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
+ args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]);
type = gfc_typenode_for_spec (&expr->ts);
se->expr = build_fold_indirect_ref (args[1]);
}
+/* 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);
+ 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
}
+/* FRACTION (s) is translated into frexp (s, &dummy_int). */
+static void
+gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
+{
+ tree arg, type, tmp;
+ int frexp;
+
+ switch (expr->ts.kind)
+ {
+ case 4:
+ frexp = BUILT_IN_FREXPF;
+ break;
+ case 8:
+ frexp = BUILT_IN_FREXP;
+ break;
+ case 10:
+ case 16:
+ frexp = BUILT_IN_FREXPL;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ 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,
+ fold_convert (type, arg),
+ build_fold_addr_expr (tmp));
+ se->expr = fold_convert (type, se->expr);
+}
+
+
+/* NEAREST (s, dir) is translated into
+ tmp = copysign (INF, 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;
+
+ switch (expr->ts.kind)
+ {
+ case 4:
+ nextafter = BUILT_IN_NEXTAFTERF;
+ copysign = BUILT_IN_COPYSIGNF;
+ inf = BUILT_IN_INFF;
+ break;
+ case 8:
+ nextafter = BUILT_IN_NEXTAFTER;
+ copysign = BUILT_IN_COPYSIGN;
+ inf = BUILT_IN_INF;
+ break;
+ case 10:
+ case 16:
+ nextafter = BUILT_IN_NEXTAFTERL;
+ copysign = BUILT_IN_COPYSIGNL;
+ inf = BUILT_IN_INFL;
+ 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),
+ fold_convert (type, args[1]));
+ se->expr = build_call_expr (built_in_decls[nextafter], 2,
+ fold_convert (type, args[0]), tmp);
+ se->expr = fold_convert (type, se->expr);
+}
+
+
+/* SPACING (s) is translated into
+ int e;
+ if (s == 0)
+ res = tiny;
+ else
+ {
+ frexp (s, &e);
+ e = e - prec;
+ e = MAX_EXPR (e, emin);
+ res = scalbn (1., e);
+ }
+ return res;
+
+ where prec is the precision of s, gfc_real_kinds[k].digits,
+ emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
+ and tiny is tiny(s), gfc_real_kinds[k].tiny. */
+
+static void
+gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
+{
+ tree arg, type, prec, emin, tiny, res, e;
+ tree cond, tmp;
+ int frexp, scalbn, k;
+ stmtblock_t block;
+
+ 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);
+
+ switch (expr->ts.kind)
+ {
+ case 4:
+ frexp = BUILT_IN_FREXPF;
+ scalbn = BUILT_IN_SCALBNF;
+ break;
+ case 8:
+ frexp = BUILT_IN_FREXP;
+ scalbn = BUILT_IN_SCALBN;
+ break;
+ case 10:
+ case 16:
+ frexp = BUILT_IN_FREXPL;
+ scalbn = BUILT_IN_SCALBNL;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ arg = gfc_evaluate_now (arg, &se->pre);
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ e = gfc_create_var (integer_type_node, NULL);
+ res = gfc_create_var (type, NULL);
+
+
+ /* 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));
+ gfc_add_expr_to_block (&block, tmp);
+
+ tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec);
+ gfc_add_modify_expr (&block, e, fold_build2 (MAX_EXPR, integer_type_node,
+ tmp, emin));
+
+ tmp = build_call_expr (built_in_decls[scalbn], 2,
+ build_real_from_int_cst (type, integer_one_node), e);
+ gfc_add_modify_expr (&block, res, tmp);
+
+ /* Finish by building the IF statement. */
+ cond = fold_build2 (EQ_EXPR, boolean_type_node, arg,
+ build_real_from_int_cst (type, integer_zero_node));
+ tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
+ gfc_finish_block (&block));
+
+ gfc_add_expr_to_block (&se->pre, tmp);
+ se->expr = res;
+}
+
+
+/* RRSPACING (s) is translated into
+ int e;
+ real x;
+ x = fabs (s);
+ if (x != 0)
+ {
+ frexp (s, &e);
+ x = scalbn (x, precision - e);
+ }
+ return x;
+
+ where precision is gfc_real_kinds[k].digits. */
+
+static void
+gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
+{
+ tree arg, type, e, x, cond, stmt, tmp;
+ int frexp, scalbn, fabs, prec, k;
+ stmtblock_t block;
+
+ k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
+ prec = gfc_real_kinds[k].digits;
+ switch (expr->ts.kind)
+ {
+ case 4:
+ frexp = BUILT_IN_FREXPF;
+ scalbn = BUILT_IN_SCALBNF;
+ fabs = BUILT_IN_FABSF;
+ break;
+ case 8:
+ frexp = BUILT_IN_FREXP;
+ scalbn = BUILT_IN_SCALBN;
+ fabs = BUILT_IN_FABS;
+ break;
+ case 10:
+ case 16:
+ frexp = BUILT_IN_FREXPL;
+ scalbn = BUILT_IN_SCALBNL;
+ fabs = BUILT_IN_FABSL;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ arg = gfc_evaluate_now (arg, &se->pre);
+
+ e = gfc_create_var (integer_type_node, NULL);
+ x = gfc_create_var (type, NULL);
+ gfc_add_modify_expr (&se->pre, x,
+ build_call_expr (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));
+ 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);
+ gfc_add_modify_expr (&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 ());
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ se->expr = fold_convert (type, x);
+}
+
+
+/* SCALE (s, i) is translated into scalbn (s, i). */
+static void
+gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
+{
+ tree args[2], type;
+ int scalbn;
+
+ switch (expr->ts.kind)
+ {
+ case 4:
+ scalbn = BUILT_IN_SCALBNF;
+ break;
+ case 8:
+ scalbn = BUILT_IN_SCALBN;
+ break;
+ case 10:
+ case 16:
+ scalbn = BUILT_IN_SCALBNL;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ 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,
+ fold_convert (type, args[0]),
+ fold_convert (integer_type_node, args[1]));
+ se->expr = fold_convert (type, se->expr);
+}
+
+
+/* SET_EXPONENT (s, i) is translated into
+ scalbn (frexp (s, &dummy_int), i). */
+static void
+gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
+{
+ tree args[2], type, tmp;
+ int frexp, scalbn;
+
+ switch (expr->ts.kind)
+ {
+ case 4:
+ frexp = BUILT_IN_FREXPF;
+ scalbn = BUILT_IN_SCALBNF;
+ break;
+ case 8:
+ frexp = BUILT_IN_FREXP;
+ scalbn = BUILT_IN_SCALBN;
+ break;
+ case 10:
+ case 16:
+ frexp = BUILT_IN_FREXPL;
+ scalbn = BUILT_IN_SCALBNL;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ 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,
+ fold_convert (type, args[0]),
+ build_fold_addr_expr (tmp));
+ se->expr = build_call_expr (built_in_decls[scalbn], 2, tmp,
+ fold_convert (integer_type_node, args[1]));
+ se->expr = fold_convert (type, se->expr);
+}
+
+
static void
gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
{
argse.data_not_needed = 1;
gfc_conv_expr (&argse, actual->expr);
gfc_add_block_to_block (&se->pre, &argse.pre);
- tmp = build2 (NE_EXPR, boolean_type_node, argse.expr,
- null_pointer_node);
+ tmp = fold_build2 (NE_EXPR, boolean_type_node,
+ argse.expr, null_pointer_node);
tmp = gfc_evaluate_now (tmp, &se->pre);
- se->expr = build3 (COND_EXPR, pvoid_type_node,
- tmp, fncall1, fncall0);
+ se->expr = fold_build3 (COND_EXPR, pvoid_type_node,
+ tmp, fncall1, fncall0);
}
else
se->expr = fncall1;
}
+/* Helper function to compute the size of a character variable,
+ excluding the terminating null characters. The result has
+ gfc_array_index_type type. */
+
+static tree
+size_of_string_in_bytes (int kind, tree string_length)
+{
+ tree bytesize;
+ int i = gfc_validate_kind (BT_CHARACTER, kind, false);
+
+ bytesize = build_int_cst (gfc_array_index_type,
+ gfc_character_kinds[i].bit_size / 8);
+
+ return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize,
+ fold_convert (gfc_array_index_type, string_length));
+}
+
+
static void
gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
{
tree tmp;
tree lower;
tree upper;
- /*tree stride;*/
int n;
arg = expr->value.function.actual->expr;
/* Obtain the source word length. */
if (arg->ts.type == BT_CHARACTER)
- source_bytes = fold_convert (gfc_array_index_type,
- argse.string_length);
+ source_bytes = size_of_string_in_bytes (arg->ts.kind,
+ argse.string_length);
else
source_bytes = fold_convert (gfc_array_index_type,
size_in_bytes (type));
/* Obtain the argument's word length. */
if (arg->ts.type == BT_CHARACTER)
- tmp = fold_convert (gfc_array_index_type, argse.string_length);
+ tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
else
tmp = fold_convert (gfc_array_index_type,
size_in_bytes (type));
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
+ = gfc_build_compare_string (args[0], args[1], args[2], args[3],
+ expr->value.function.actual->expr->ts.kind);
+ 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. */
/* Obtain the source word length. */
if (arg->expr->ts.type == BT_CHARACTER)
- tmp = fold_convert (gfc_array_index_type, argse.string_length);
+ tmp = size_of_string_in_bytes (arg->expr->ts.kind,
+ argse.string_length);
else
tmp = fold_convert (gfc_array_index_type,
size_in_bytes (source_type));
/* Clean up if it was repacked. */
gfc_init_block (&block);
tmp = gfc_conv_array_data (argse.expr);
- tmp = build2 (NE_EXPR, boolean_type_node, source, tmp);
+ tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp);
tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &se->post);
/* Obtain the source word length. */
if (arg->expr->ts.type == BT_CHARACTER)
- tmp = fold_convert (gfc_array_index_type, argse.string_length);
+ tmp = size_of_string_in_bytes (arg->expr->ts.kind,
+ argse.string_length);
else
tmp = fold_convert (gfc_array_index_type,
size_in_bytes (source_type));
if (arg->expr->ts.type == BT_CHARACTER)
{
- tmp = fold_convert (gfc_array_index_type, argse.string_length);
+ tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
}
else
moldsize = size_in_bytes (type);
/* Use memcpy to do the transfer. */
- tmp = build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl);
+ tmp = fold_build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl);
tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
fold_convert (pvoid_type_node, tmp),
fold_convert (pvoid_type_node, ptr),
gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
tmp = gfc_conv_descriptor_data_get (arg1se.expr);
- tmp = build2 (NE_EXPR, boolean_type_node, tmp,
- fold_convert (TREE_TYPE (tmp), null_pointer_node));
+ 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_se arg2se;
tree tmp2;
tree tmp;
- 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 (NE_EXPR, boolean_type_node, tmp2,
- fold_convert (TREE_TYPE (tmp2), null_pointer_node));
+ tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp2,
+ fold_convert (TREE_TYPE (tmp2), null_pointer_node));
se->expr = tmp;
}
else
nonzero_charlen = NULL_TREE;
if (arg1->expr->ts.type == BT_CHARACTER)
- nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
- arg1->expr->ts.cl->backend_decl,
- integer_zero_node);
+ nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
+ arg1->expr->ts.cl->backend_decl,
+ integer_zero_node);
if (ss1 == gfc_ss_terminator)
{
gfc_conv_expr (&arg2se, arg2->expr);
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);
- tmp2 = build2 (NE_EXPR, boolean_type_node, arg1se.expr,
- null_pointer_node);
- se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, tmp, tmp2);
+ tmp = fold_build2 (EQ_EXPR, boolean_type_node,
+ arg1se.expr, arg2se.expr);
+ tmp2 = fold_build2 (NE_EXPR, boolean_type_node,
+ arg1se.expr, null_pointer_node);
+ se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+ tmp, tmp2);
}
else
{
-
/* An array pointer of zero length is not associated if target is
present. */
arg1se.descriptor_only = 1;
gfc_conv_expr_lhs (&arg1se, arg1->expr);
tmp = gfc_conv_descriptor_stride (arg1se.expr,
gfc_rank_cst[arg1->expr->rank - 1]);
- nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
- tmp, build_int_cst (TREE_TYPE (tmp), 0));
+ nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
/* A pointer to an array, call library function _gfor_associated. */
gcc_assert (ss2 != gfc_ss_terminator);
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 = build2 (TRUTH_AND_EXPR, boolean_type_node,
- se->expr, nonzero_arraylen);
-
+ se->expr = build_call_expr (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,
+ se->expr, nonzero_arraylen);
}
/* If target is present zero character length pointers cannot
be associated. */
if (nonzero_charlen != NULL_TREE)
- se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
- se->expr, nonzero_charlen);
+ se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+ se->expr, nonzero_charlen);
}
se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
}
-/* 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. */
+/* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
static void
-gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_sc_kind (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);
+ tree args[2];
- se->expr = convert (type, se->expr);
+ 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 = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
}
/* 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;
+ gfc_clear_ts (&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);
}
static void
gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
{
- tree gfc_int4_type_node = gfc_get_int_type (4);
tree var;
tree len;
tree addr;
tree tmp;
- tree type;
tree cond;
tree fndecl;
+ tree function;
tree *args;
unsigned int num_args;
num_args = gfc_intrinsic_argument_list_length (expr) + 2;
args = alloca (sizeof (tree) * num_args);
- type = build_pointer_type (gfc_character1_type_node);
- var = gfc_create_var (type, "pstr");
+ var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
addr = gfc_build_addr_expr (ppvoid_type_node, var);
- len = gfc_create_var (gfc_int4_type_node, "len");
+ 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[1] = addr;
- fndecl = build_addr (gfor_fndecl_string_trim, current_function_decl);
- tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_trim)),
- fndecl, num_args, args);
+ if (expr->ts.kind == 1)
+ function = gfor_fndecl_string_trim;
+ else if (expr->ts.kind == 4)
+ function = gfor_fndecl_string_trim_char4;
+ else
+ gcc_unreachable ();
+
+ fndecl = build_addr (function, current_function_decl);
+ tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
+ num_args, args);
gfc_add_expr_to_block (&se->pre, tmp);
/* Free the temporary afterwards, if necessary. */
- cond = build2 (GT_EXPR, boolean_type_node, len,
- build_int_cst (TREE_TYPE (len), 0));
+ 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 ());
gfc_add_expr_to_block (&se->post, tmp);
{
tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
tree type, cond, tmp, count, exit_label, n, max, largest;
+ tree size;
stmtblock_t block, body;
int i;
+ /* We store in charsize the size of a character. */
+ i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
+ size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
+
/* Get the arguments. */
gfc_conv_intrinsic_function_args (se, expr, args, 3);
slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
/* 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,
/* Generate the code to do the repeat operation:
for (i = 0; i < ncopies; i++)
- memmove (dest + (i * slen), src, slen); */
+ memmove (dest + (i * slen * size), src, slen*size); */
gfc_start_block (&block);
count = gfc_create_var (ncopies_type, "count");
gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
- /* Call memmove (dest + (i*slen), src, slen). */
+ /* Call memmove (dest + (i*slen*size), src, slen*size). */
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 (POINTER_PLUS_EXPR, pchar_type_node,
- fold_convert (pchar_type_node, dest),
+ tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
+ tmp, fold_convert (gfc_charlen_type_node, 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, slen);
+ tmp = build_call_expr (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);
/* Increment count. */
- tmp = build2 (PLUS_EXPR, ncopies_type, count,
- build_int_cst (TREE_TYPE (count), 1));
+ tmp = fold_build2 (PLUS_EXPR, ncopies_type,
+ count, build_int_cst (TREE_TYPE (count), 1));
gfc_add_modify_expr (&body, count, tmp);
/* Build the loop. */
{
gfc_intrinsic_sym *isym;
const char *name;
- int lib;
+ int lib, kind;
+ tree fndecl;
isym = expr->value.function.isym;
gfc_conv_intrinsic_trim (se, expr);
break;
+ case GFC_ISYM_SC_KIND:
+ gfc_conv_intrinsic_sc_kind (se, expr);
+ break;
+
case GFC_ISYM_SI_KIND:
gfc_conv_intrinsic_si_kind (se, expr);
break;
break;
case GFC_ISYM_SCAN:
- gfc_conv_intrinsic_scan (se, expr);
+ kind = expr->value.function.actual->expr->ts.kind;
+ if (kind == 1)
+ fndecl = gfor_fndecl_string_scan;
+ else if (kind == 4)
+ fndecl = gfor_fndecl_string_scan_char4;
+ else
+ gcc_unreachable ();
+
+ gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
break;
case GFC_ISYM_VERIFY:
- gfc_conv_intrinsic_verify (se, expr);
+ kind = expr->value.function.actual->expr->ts.kind;
+ if (kind == 1)
+ fndecl = gfor_fndecl_string_verify;
+ else if (kind == 4)
+ fndecl = gfor_fndecl_string_verify_char4;
+ else
+ gcc_unreachable ();
+
+ gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
break;
case GFC_ISYM_ALLOCATED:
break;
case GFC_ISYM_ADJUSTL:
- gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
+ if (expr->ts.kind == 1)
+ fndecl = gfor_fndecl_adjustl;
+ else if (expr->ts.kind == 4)
+ fndecl = gfor_fndecl_adjustl_char4;
+ else
+ gcc_unreachable ();
+
+ gfc_conv_intrinsic_adjust (se, expr, fndecl);
break;
case GFC_ISYM_ADJUSTR:
- gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
+ if (expr->ts.kind == 1)
+ fndecl = gfor_fndecl_adjustr;
+ else if (expr->ts.kind == 4)
+ fndecl = gfor_fndecl_adjustr_char4;
+ else
+ gcc_unreachable ();
+
+ gfc_conv_intrinsic_adjust (se, expr, fndecl);
break;
case GFC_ISYM_AIMAG:
gfc_conv_intrinsic_fdate (se, expr);
break;
+ case GFC_ISYM_FRACTION:
+ gfc_conv_intrinsic_fraction (se, expr);
+ break;
+
case GFC_ISYM_IAND:
gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
break;
break;
case GFC_ISYM_INDEX:
- gfc_conv_intrinsic_index (se, expr);
+ kind = expr->value.function.actual->expr->ts.kind;
+ if (kind == 1)
+ fndecl = gfor_fndecl_string_index;
+ else if (kind == 4)
+ fndecl = gfor_fndecl_string_index_char4;
+ else
+ gcc_unreachable ();
+
+ gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
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_LSHIFT:
gfc_conv_intrinsic_rlshift (se, expr, 0);
break;
break;
case GFC_ISYM_MAX:
- gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
+ if (expr->ts.type == BT_CHARACTER)
+ gfc_conv_intrinsic_minmax_char (se, expr, 1);
+ else
+ gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
break;
case GFC_ISYM_MAXLOC:
break;
case GFC_ISYM_MIN:
- gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
+ if (expr->ts.type == BT_CHARACTER)
+ gfc_conv_intrinsic_minmax_char (se, expr, -1);
+ else
+ gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
break;
case GFC_ISYM_MINLOC:
gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
break;
+ case GFC_ISYM_NEAREST:
+ gfc_conv_intrinsic_nearest (se, expr);
+ break;
+
case GFC_ISYM_NOT:
gfc_conv_intrinsic_not (se, expr);
break;
gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
break;
+ case GFC_ISYM_RRSPACING:
+ gfc_conv_intrinsic_rrspacing (se, expr);
+ break;
+
+ case GFC_ISYM_SET_EXPONENT:
+ gfc_conv_intrinsic_set_exponent (se, expr);
+ break;
+
+ case GFC_ISYM_SCALE:
+ gfc_conv_intrinsic_scale (se, expr);
+ break;
+
case GFC_ISYM_SIGN:
gfc_conv_intrinsic_sign (se, expr);
break;
gfc_conv_intrinsic_sizeof (se, expr);
break;
+ case GFC_ISYM_SPACING:
+ gfc_conv_intrinsic_spacing (se, expr);
+ break;
+
case GFC_ISYM_SUM:
gfc_conv_intrinsic_arith (se, expr, PLUS_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
