OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/33387 (Fortran front-end should translate intrinsics by calling C99 function instead of libgfortran functions)

Browse Source 
PR fortran/33387

	* trans.h: Remove prototypes for gfor_fndecl_math_exponent4,
	gfor_fndecl_math_exponent8, gfor_fndecl_math_exponent10 and
	gfor_fndecl_math_exponent16.
	* f95-lang.c (build_builtin_fntypes): Add new function types.
	(gfc_init_builtin_functions): Add new builtins for nextafter,
	frexp, ldexp, fabs, scalbn and inf.
	* iresolve.c (gfc_resolve_rrspacing): Don't add hidden arguments.
	(gfc_resolve_scale): Don't convert type of second argument.
	(gfc_resolve_set_exponent): Likewise.
	(gfc_resolve_size): Don't add hidden arguments.
	* trans-decl.c: Remove gfor_fndecl_math_exponent4,
	gfor_fndecl_math_exponent8, gfor_fndecl_math_exponent10 and
	gfor_fndecl_math_exponent16.
	* trans-intrinsic.c (gfc_intrinsic_map): Remove intrinsics
	for scalbn, fraction, nearest, rrspacing, set_exponent and
	spacing.
	(gfc_conv_intrinsic_exponent): Directly call frexp.
	(gfc_conv_intrinsic_fraction, gfc_conv_intrinsic_nearest,
	gfc_conv_intrinsic_spacing, gfc_conv_intrinsic_rrspacing,
	gfc_conv_intrinsic_scale, gfc_conv_intrinsic_set_exponent): New
	functions.
	(gfc_conv_intrinsic_function): Use the new functions above.

From-SVN: r132713
This commit is contained in:
Francois-Xavier Coudert 2008-02-27 14:32:02 +00:00 committed by François-Xavier Coudert
parent 8bf6e27028
commit b5a4419cde
6 changed files with 431 additions and 177 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
gcc/fortran/ChangeLog
View File

@ -1,3 +1,29 @@
2008-02-27 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/33387
* trans.h: Remove prototypes for gfor_fndecl_math_exponent4,
gfor_fndecl_math_exponent8, gfor_fndecl_math_exponent10 and
gfor_fndecl_math_exponent16.
* f95-lang.c (build_builtin_fntypes): Add new function types.
(gfc_init_builtin_functions): Add new builtins for nextafter,
frexp, ldexp, fabs, scalbn and inf.
* iresolve.c (gfc_resolve_rrspacing): Don't add hidden arguments.
(gfc_resolve_scale): Don't convert type of second argument.
(gfc_resolve_set_exponent): Likewise.
(gfc_resolve_size): Don't add hidden arguments.
* trans-decl.c: Remove gfor_fndecl_math_exponent4,
gfor_fndecl_math_exponent8, gfor_fndecl_math_exponent10 and
gfor_fndecl_math_exponent16.
* trans-intrinsic.c (gfc_intrinsic_map): Remove intrinsics
for scalbn, fraction, nearest, rrspacing, set_exponent and
spacing.
(gfc_conv_intrinsic_exponent): Directly call frexp.
(gfc_conv_intrinsic_fraction, gfc_conv_intrinsic_nearest,
gfc_conv_intrinsic_spacing, gfc_conv_intrinsic_rrspacing,
gfc_conv_intrinsic_scale, gfc_conv_intrinsic_set_exponent): New
functions.
(gfc_conv_intrinsic_function): Use the new functions above.
2008-02-26 Tobias Burnus <burnus@net-b.de>
PR fortran/35033

57
gcc/fortran/f95-lang.c
View File

@ -756,6 +756,16 @@ build_builtin_fntypes (tree *fntype, tree type)
tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node);
tmp = tree_cons (NULL_TREE, type, tmp);
fntype[2] = build_function_type (type, tmp);
/* type (*) (void) */
fntype[3] = build_function_type (type, void_list_node);
/* type (*) (type, &int) */
tmp = tree_cons (NULL_TREE, type, void_list_node);
tmp = tree_cons (NULL_TREE, build_pointer_type (integer_type_node), tmp);
fntype[4] = build_function_type (type, tmp);
/* type (*) (type, int) */
tmp = tree_cons (NULL_TREE, type, void_list_node);
tmp = tree_cons (NULL_TREE, integer_type_node, tmp);
fntype[5] = build_function_type (type, tmp);
}
@ -806,12 +816,12 @@ gfc_init_builtin_functions (void)
ATTR_CONST_NOTHROW_LIST
};
tree mfunc_float[3];
tree mfunc_double[3];
tree mfunc_longdouble[3];
tree mfunc_cfloat[3];
tree mfunc_cdouble[3];
tree mfunc_clongdouble[3];
tree mfunc_float[6];
tree mfunc_double[6];
tree mfunc_longdouble[6];
tree mfunc_cfloat[6];
tree mfunc_cdouble[6];
tree mfunc_clongdouble[6];
tree func_cfloat_float, func_float_cfloat;
tree func_cdouble_double, func_double_cdouble;
tree func_clongdouble_longdouble, func_longdouble_clongdouble;
@ -902,6 +912,34 @@ gfc_init_builtin_functions (void)
gfc_define_builtin ("__builtin_copysignf", mfunc_float[1],
BUILT_IN_COPYSIGNF, "copysignf", true);
gfc_define_builtin ("__builtin_nextafterl", mfunc_longdouble[1],
BUILT_IN_NEXTAFTERL, "nextafterl", true);
gfc_define_builtin ("__builtin_nextafter", mfunc_double[1],
BUILT_IN_NEXTAFTER, "nextafter", true);
gfc_define_builtin ("__builtin_nextafterf", mfunc_float[1],
BUILT_IN_NEXTAFTERF, "nextafterf", true);
gfc_define_builtin ("__builtin_frexpl", mfunc_longdouble[4],
BUILT_IN_FREXPL, "frexpl", false);
gfc_define_builtin ("__builtin_frexp", mfunc_double[4],
BUILT_IN_FREXP, "frexp", false);
gfc_define_builtin ("__builtin_frexpf", mfunc_float[4],
BUILT_IN_FREXPF, "frexpf", false);
gfc_define_builtin ("__builtin_fabsl", mfunc_longdouble[0],
BUILT_IN_FABSL, "fabsl", true);
gfc_define_builtin ("__builtin_fabs", mfunc_double[0],
BUILT_IN_FABS, "fabs", true);
gfc_define_builtin ("__builtin_fabsf", mfunc_float[0],
BUILT_IN_FABSF, "fabsf", true);
gfc_define_builtin ("__builtin_scalbnl", mfunc_longdouble[5],
BUILT_IN_SCALBNL, "scalbnl", true);
gfc_define_builtin ("__builtin_scalbn", mfunc_double[5],
BUILT_IN_SCALBN, "scalbn", true);
gfc_define_builtin ("__builtin_scalbnf", mfunc_float[5],
BUILT_IN_SCALBNF, "scalbnf", true);
gfc_define_builtin ("__builtin_fmodl", mfunc_longdouble[1],
BUILT_IN_FMODL, "fmodl", true);
gfc_define_builtin ("__builtin_fmod", mfunc_double[1],
@ -909,6 +947,13 @@ gfc_init_builtin_functions (void)
gfc_define_builtin ("__builtin_fmodf", mfunc_float[1],
BUILT_IN_FMODF, "fmodf", true);
gfc_define_builtin ("__builtin_infl", mfunc_longdouble[3],
BUILT_IN_INFL, "__builtin_infl", true);
gfc_define_builtin ("__builtin_inf", mfunc_double[3],
BUILT_IN_INF, "__builtin_inf", true);
gfc_define_builtin ("__builtin_inff", mfunc_float[3],
BUILT_IN_INFF, "__builtin_inff", true);
/* lround{f,,l} and llround{f,,l} */
type = tree_cons (NULL_TREE, float_type_node, void_list_node);
tmp = build_function_type (long_integer_type_node, type);

101
gcc/fortran/iresolve.c
View File

@ -1853,47 +1853,15 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
void
gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
{
int k;
gfc_actual_arglist *prec;
f->ts = x->ts;
f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
/* Create a hidden argument to the library routines for rrspacing. This
hidden argument is the precision of x. */
k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
prec = gfc_get_actual_arglist ();
prec->name = "p";
prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
/* The library routine expects INTEGER(4). */
if (prec->expr->ts.kind != gfc_c_int_kind)
{
gfc_typespec ts;
gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
gfc_convert_type (prec->expr, &ts, 2);
}
f->value.function.actual->next = prec;
}
void
gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i)
gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
{
f->ts = x->ts;
/* The implementation calls scalbn which takes an int as the
second argument. */
if (i->ts.kind != gfc_c_int_kind)
{
gfc_typespec ts;
gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
gfc_convert_type_warn (i, &ts, 2, 0);
}
f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
}
@ -1921,22 +1889,10 @@ gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
void
gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x, gfc_expr *i)
gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
gfc_expr *i ATTRIBUTE_UNUSED)
{
f->ts = x->ts;
/* The library implementation uses GFC_INTEGER_4 unconditionally,
convert type so we don't have to implement all possible
permutations. */
if (i->ts.kind != gfc_c_int_kind)
{
gfc_typespec ts;
gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
gfc_convert_type_warn (i, &ts, 2, 0);
}
f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
}
@ -2016,59 +1972,8 @@ gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
void
gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
{
int k;
gfc_actual_arglist *prec, *tiny, *emin_1;
f->ts = x->ts;
f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
/* Create hidden arguments to the library routine for spacing. These
hidden arguments are tiny(x), min_exponent - 1, and the precision
of x. */
k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
tiny = gfc_get_actual_arglist ();
tiny->name = "tiny";
tiny->expr = gfc_get_expr ();
tiny->expr->expr_type = EXPR_CONSTANT;
tiny->expr->where = gfc_current_locus;
tiny->expr->ts.type = x->ts.type;
tiny->expr->ts.kind = x->ts.kind;
mpfr_init (tiny->expr->value.real);
mpfr_set (tiny->expr->value.real, gfc_real_kinds[k].tiny, GFC_RND_MODE);
emin_1 = gfc_get_actual_arglist ();
emin_1->name = "emin";
emin_1->expr = gfc_int_expr (gfc_real_kinds[k].min_exponent - 1);
/* The library routine expects INTEGER(4). */
if (emin_1->expr->ts.kind != gfc_c_int_kind)
{
gfc_typespec ts;
gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
gfc_convert_type (emin_1->expr, &ts, 2);
}
emin_1->next = tiny;
prec = gfc_get_actual_arglist ();
prec->name = "prec";
prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
/* The library routine expects INTEGER(4). */
if (prec->expr->ts.kind != gfc_c_int_kind)
{
gfc_typespec ts;
gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
gfc_convert_type (prec->expr, &ts, 2);
}
prec->next = emin_1;
f->value.function.actual->next = prec;
}

27
gcc/fortran/trans-decl.c
View File

@ -102,10 +102,6 @@ gfc_powdecl_list gfor_fndecl_math_powi[4][3];
tree gfor_fndecl_math_ishftc4;
tree gfor_fndecl_math_ishftc8;
tree gfor_fndecl_math_ishftc16;
tree gfor_fndecl_math_exponent4;
tree gfor_fndecl_math_exponent8;
tree gfor_fndecl_math_exponent10;
tree gfor_fndecl_math_exponent16;
/* String functions. */
@ -2010,10 +2006,6 @@ gfc_build_intrinsic_function_decls (void)
tree gfc_int8_type_node = gfc_get_int_type (8);
tree gfc_int16_type_node = gfc_get_int_type (16);
tree gfc_logical4_type_node = gfc_get_logical_type (4);
tree gfc_real4_type_node = gfc_get_real_type (4);
tree gfc_real8_type_node = gfc_get_real_type (8);
tree gfc_real10_type_node = gfc_get_real_type (10);
tree gfc_real16_type_node = gfc_get_real_type (16);
/* String functions. */
gfor_fndecl_compare_string =
@ -2199,25 +2191,6 @@ gfc_build_intrinsic_function_decls (void)
gfc_int4_type_node,
gfc_int4_type_node);
gfor_fndecl_math_exponent4 =
gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
gfc_int4_type_node,
1, gfc_real4_type_node);
gfor_fndecl_math_exponent8 =
gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
gfc_int4_type_node,
1, gfc_real8_type_node);
if (gfc_real10_type_node)
gfor_fndecl_math_exponent10 =
gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
gfc_int4_type_node, 1,
gfc_real10_type_node);
if (gfc_real16_type_node)
gfor_fndecl_math_exponent16 =
gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
gfc_int4_type_node, 1,
gfc_real16_type_node);
/* BLAS functions. */
{
tree pint = build_pointer_type (integer_type_node);

393
gcc/fortran/trans-intrinsic.c
View File

@ -104,43 +104,19 @@ gfc_intrinsic_map_t;
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) \
{ 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, \
NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
{
/* 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),
/* End the list. */
LIBF_FUNCTION (NONE, NULL, false)
{ GFC_ISYM_NONE, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS,
END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS,
true, false, true, NULL, NULL_TREE, NULL_TREE, NULL_TREE,
NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
};
#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. */
@ -727,38 +703,43 @@ gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
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;
tree arg, type, res, tmp;
int frexp;
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
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. */
@ -2823,6 +2804,310 @@ gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
}
/* 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)
{
@ -3899,6 +4184,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
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;
@ -4037,6 +4326,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
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;
@ -4053,6 +4346,18 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
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;
@ -4065,6 +4370,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
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;

4
gcc/fortran/trans.h
View File

@ -529,10 +529,6 @@ extern GTY(()) gfc_powdecl_list gfor_fndecl_math_powi[4][3];
extern GTY(()) tree gfor_fndecl_math_ishftc4;
extern GTY(()) tree gfor_fndecl_math_ishftc8;
extern GTY(()) tree gfor_fndecl_math_ishftc16;
extern GTY(()) tree gfor_fndecl_math_exponent4;
extern GTY(()) tree gfor_fndecl_math_exponent8;
extern GTY(()) tree gfor_fndecl_math_exponent10;
extern GTY(()) tree gfor_fndecl_math_exponent16;
/* BLAS functions. */
extern GTY(()) tree gfor_fndecl_sgemm;