tree
gfc_build_inf_or_huge (tree type, int kind)
{
if (HONOR_INFINITIES (TYPE_MODE (type)))
{
REAL_VALUE_TYPE real;
real_inf (&real);
return build_real (type, real);
}
else
{
int k = gfc_validate_kind (BT_REAL, kind, false);
return gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge, kind, 0);
}
}
void
real_from_mpfr (REAL_VALUE_TYPE *r, mpfr_srcptr m, tree type, mp_rnd_t rndmode)
{
/* We use a string as an intermediate type. */
char buf[128], *rstr;
mp_exp_t exp;
/* Take care of Infinity and NaN. */
if (mpfr_inf_p (m))
{
real_inf (r);
if (mpfr_sgn (m) < 0)
*r = real_value_negate (r);
return;
}
if (mpfr_nan_p (m))
{
real_nan (r, "", 1, TYPE_MODE (type));
return;
}
rstr = mpfr_get_str (NULL, &exp, 16, 0, m, rndmode);
/* The additional 12 chars add space for the sprintf below. This
leaves 6 digits for the exponent which is supposedly enough. */
gcc_assert (rstr != NULL && strlen (rstr) < sizeof (buf) - 12);
/* REAL_VALUE_ATOF expects the exponent for mantissa * 2**exp,
mpfr_get_str returns the exponent for mantissa * 16**exp, adjust
for that. */
exp *= 4;
if (rstr[0] == '-')
sprintf (buf, "-0x.%sp%d", &rstr[1], (int) exp);
else
sprintf (buf, "0x.%sp%d", rstr, (int) exp);
mpfr_free_str (rstr);
real_from_string (r, buf);
}
static bool
fold_const_call_cc (real_value *result_real, real_value *result_imag,
built_in_function fn, const real_value *arg_real,
const real_value *arg_imag, const real_format *format)
{
switch (fn)
{
CASE_FLT_FN (BUILT_IN_CCOS):
return do_mpc_arg1 (result_real, result_imag, mpc_cos,
arg_real, arg_imag, format);
CASE_FLT_FN (BUILT_IN_CCOSH):
return do_mpc_arg1 (result_real, result_imag, mpc_cosh,
arg_real, arg_imag, format);
CASE_FLT_FN (BUILT_IN_CPROJ):
if (real_isinf (arg_real) || real_isinf (arg_imag))
{
real_inf (result_real);
*result_imag = dconst0;
result_imag->sign = arg_imag->sign;
}
else
{
*result_real = *arg_real;
*result_imag = *arg_imag;
}
return true;
CASE_FLT_FN (BUILT_IN_CSIN):
return do_mpc_arg1 (result_real, result_imag, mpc_sin,
arg_real, arg_imag, format);
CASE_FLT_FN (BUILT_IN_CSINH):
return do_mpc_arg1 (result_real, result_imag, mpc_sinh,
arg_real, arg_imag, format);
CASE_FLT_FN (BUILT_IN_CTAN):
return do_mpc_arg1 (result_real, result_imag, mpc_tan,
arg_real, arg_imag, format);
CASE_FLT_FN (BUILT_IN_CTANH):
return do_mpc_arg1 (result_real, result_imag, mpc_tanh,
arg_real, arg_imag, format);
CASE_FLT_FN (BUILT_IN_CLOG):
return do_mpc_arg1 (result_real, result_imag, mpc_log,
arg_real, arg_imag, format);
CASE_FLT_FN (BUILT_IN_CSQRT):
return do_mpc_arg1 (result_real, result_imag, mpc_sqrt,
arg_real, arg_imag, format);
CASE_FLT_FN (BUILT_IN_CASIN):
return do_mpc_arg1 (result_real, result_imag, mpc_asin,
arg_real, arg_imag, format);
CASE_FLT_FN (BUILT_IN_CACOS):
return do_mpc_arg1 (result_real, result_imag, mpc_acos,
arg_real, arg_imag, format);
CASE_FLT_FN (BUILT_IN_CATAN):
return do_mpc_arg1 (result_real, result_imag, mpc_atan,
arg_real, arg_imag, format);
CASE_FLT_FN (BUILT_IN_CASINH):
return do_mpc_arg1 (result_real, result_imag, mpc_asinh,
arg_real, arg_imag, format);
CASE_FLT_FN (BUILT_IN_CACOSH):
return do_mpc_arg1 (result_real, result_imag, mpc_acosh,
arg_real, arg_imag, format);
CASE_FLT_FN (BUILT_IN_CATANH):
return do_mpc_arg1 (result_real, result_imag, mpc_atanh,
arg_real, arg_imag, format);
CASE_FLT_FN (BUILT_IN_CEXP):
return do_mpc_arg1 (result_real, result_imag, mpc_exp,
arg_real, arg_imag, format);
default:
return false;
}
}
static bool
fold_const_call_cc (real_value *result_real, real_value *result_imag,
combined_fn fn, const real_value *arg_real,
const real_value *arg_imag, const real_format *format)
{
switch (fn)
{
CASE_CFN_CCOS:
return do_mpc_arg1 (result_real, result_imag, mpc_cos,
arg_real, arg_imag, format);
CASE_CFN_CCOSH:
return do_mpc_arg1 (result_real, result_imag, mpc_cosh,
arg_real, arg_imag, format);
CASE_CFN_CPROJ:
if (real_isinf (arg_real) || real_isinf (arg_imag))
{
real_inf (result_real);
*result_imag = dconst0;
result_imag->sign = arg_imag->sign;
}
else
{
*result_real = *arg_real;
*result_imag = *arg_imag;
}
return true;
CASE_CFN_CSIN:
return do_mpc_arg1 (result_real, result_imag, mpc_sin,
arg_real, arg_imag, format);
CASE_CFN_CSINH:
return do_mpc_arg1 (result_real, result_imag, mpc_sinh,
arg_real, arg_imag, format);
CASE_CFN_CTAN:
return do_mpc_arg1 (result_real, result_imag, mpc_tan,
arg_real, arg_imag, format);
CASE_CFN_CTANH:
return do_mpc_arg1 (result_real, result_imag, mpc_tanh,
arg_real, arg_imag, format);
CASE_CFN_CLOG:
return do_mpc_arg1 (result_real, result_imag, mpc_log,
arg_real, arg_imag, format);
CASE_CFN_CSQRT:
return do_mpc_arg1 (result_real, result_imag, mpc_sqrt,
arg_real, arg_imag, format);
CASE_CFN_CASIN:
return do_mpc_arg1 (result_real, result_imag, mpc_asin,
arg_real, arg_imag, format);
CASE_CFN_CACOS:
return do_mpc_arg1 (result_real, result_imag, mpc_acos,
arg_real, arg_imag, format);
CASE_CFN_CATAN:
return do_mpc_arg1 (result_real, result_imag, mpc_atan,
arg_real, arg_imag, format);
CASE_CFN_CASINH:
return do_mpc_arg1 (result_real, result_imag, mpc_asinh,
arg_real, arg_imag, format);
CASE_CFN_CACOSH:
return do_mpc_arg1 (result_real, result_imag, mpc_acosh,
arg_real, arg_imag, format);
CASE_CFN_CATANH:
return do_mpc_arg1 (result_real, result_imag, mpc_atanh,
arg_real, arg_imag, format);
CASE_CFN_CEXP:
return do_mpc_arg1 (result_real, result_imag, mpc_exp,
arg_real, arg_imag, format);
default:
return false;
}
}