int main(void)
{
#pragma STDC FENV_ACCESS ON
int yi;
long double y;
float d;
int e, i, err = 0;
struct l_li *p;
for (i = 0; i < sizeof t/sizeof *t; i++) {
p = t + i;
if (p->r < 0)
continue;
fesetround(p->r);
feclearexcept(FE_ALL_EXCEPT);
y = frexpl(p->x, &yi);
e = fetestexcept(INEXACT|INVALID|DIVBYZERO|UNDERFLOW|OVERFLOW);
if (!checkexceptall(e, p->e, p->r)) {
printf("%s:%d: bad fp exception: %s frexpl(%La)=%La,%lld, want %s",
p->file, p->line, rstr(p->r), p->x, p->y, p->i, estr(p->e));
printf(" got %s\n", estr(e));
err++;
}
d = ulperrl(y, p->y, p->dy);
if (!checkcr(y, p->y, p->r) || (isfinite(p->x) && yi != p->i)) {
printf("%s:%d: %s frexpl(%La) want %La,%lld got %La,%d ulperr %.3f = %a + %a\n",
p->file, p->line, rstr(p->r), p->x, p->y, p->i, y, yi, d, d-p->dy, p->dy);
err++;
}
}
return !!err;
}
GFC_INTEGER_4
exponent_r16 (GFC_REAL_16 s)
{
int ret;
frexpl (s, &ret);
return ret;
}
/* A simple Newton-Raphson method. */
long double
sqrtl (long double x)
{
long double delta, y;
int exponent;
/* Check for NaN */
if (isnanl (x))
return x;
/* Check for negative numbers */
if (x < 0.0L)
return (long double) sqrt (-1);
/* Check for zero and infinites */
if (x + x == x)
return x;
frexpl (x, &exponent);
y = ldexpl (x, -exponent / 2);
do
{
delta = y;
y = (y + x / y) * 0.5L;
delta -= y;
}
while (delta != 0.0L);
return y;
}
int main(int argc, char *argv[])
{
long double x = 0.0;
int i = 0;
if (argv) x = frexpl((long double) argc, &i);
return 0;
}
void test_frexp()
{
int ip;
static_assert((std::is_same<decltype(frexp((double)0, &ip)), double>::value), "");
static_assert((std::is_same<decltype(frexpf(0, &ip)), float>::value), "");
static_assert((std::is_same<decltype(frexpl(0, &ip)), long double>::value), "");
assert(frexp(0, &ip) == 0);
}
long double
hypotl (long double x, long double y)
{
if (isfinite (x) && isfinite (y))
{
/* Determine absolute values. */
x = fabsl (x);
y = fabsl (y);
{
/* Find the bigger and the smaller one. */
long double a;
long double b;
if (x >= y)
{
a = x;
b = y;
}
else
{
a = y;
b = x;
}
/* Now 0 <= b <= a. */
{
int e;
long double an;
long double bn;
/* Write a = an * 2^e, b = bn * 2^e with 0 <= bn <= an < 1. */
an = frexpl (a, &e);
bn = ldexpl (b, - e);
{
long double cn;
/* Through the normalization, no unneeded overflow or underflow
will occur here. */
cn = sqrtl (an * an + bn * bn);
return ldexpl (cn, e);
}
}
}
}
else
{
if (isinf (x) || isinf (y))
/* x or y is infinite. Return +Infinity. */
return HUGE_VALL;
else
/* x or y is NaN. Return NaN. */
return x + y;
}
}
cl_object
cl_decode_float(cl_object x)
{
const cl_env_ptr the_env = ecl_process_env();
int e, s;
cl_type tx = ecl_t_of(x);
float f;
switch (tx) {
case t_singlefloat: {
f = ecl_single_float(x);
if (f >= 0.0) {
s = 1;
} else {
f = -f;
s = 0;
}
f = frexpf(f, &e);
x = ecl_make_single_float(f);
break;
}
case t_doublefloat: {
double d = ecl_double_float(x);
if (d >= 0.0) {
s = 1;
} else {
d = -d;
s = 0;
}
d = frexp(d, &e);
x = ecl_make_double_float(d);
break;
}
#ifdef ECL_LONG_FLOAT
case t_longfloat: {
long double d = ecl_long_float(x);
if (d >= 0.0)
s = 1;
else {
d = -d;
s = 0;
}
d = frexpl(d, &e);
x = ecl_make_long_float(d);
break;
}
#endif
default:
FEwrong_type_nth_arg(ecl_make_fixnum(/*DECODE-FLOAT*/275),1,x,ecl_make_fixnum(/*FLOAT*/374));
}
ecl_return3(the_env, x, ecl_make_fixnum(e), ecl_make_single_float(s));
}
ATF_TC_BODY(fpclassify_long_double, tc)
{
long double d0, d1, d2, f, ip;
int e, i;
d0 = LDBL_MIN;
ATF_REQUIRE_EQ(fpclassify(d0), FP_NORMAL);
f = frexpl(d0, &e);
ATF_REQUIRE_EQ(e, LDBL_MIN_EXP);
ATF_REQUIRE_EQ(f, 0.5);
d1 = d0;
/* shift a "1" bit through the mantissa (skip the implicit bit) */
for (i = 1; i < LDBL_MANT_DIG; i++) {
d1 /= 2;
ATF_REQUIRE_EQ(fpclassify(d1), FP_SUBNORMAL);
ATF_REQUIRE(d1 > 0 && d1 < d0);
d2 = ldexpl(d0, -i);
ATF_REQUIRE_EQ(d2, d1);
d2 = modfl(d1, &ip);
ATF_REQUIRE_EQ(d2, d1);
ATF_REQUIRE_EQ(ip, 0);
f = frexpl(d1, &e);
ATF_REQUIRE_EQ(e, LDBL_MIN_EXP - i);
ATF_REQUIRE_EQ(f, 0.5);
}
d1 /= 2;
ATF_REQUIRE_EQ(fpclassify(d1), FP_ZERO);
f = frexpl(d1, &e);
ATF_REQUIRE_EQ(e, 0);
ATF_REQUIRE_EQ(f, 0);
}
GFC_REAL_10
spacing_r10 (GFC_REAL_10 s, int p, int emin, GFC_REAL_10 tiny)
{
int e;
if (s == 0.)
return tiny;
frexpl (s, &e);
e = e - p;
e = e > emin ? e : emin;
#if defined (HAVE_LDEXPL)
return ldexpl (1., e);
#else
return scalbnl (1., e);
#endif
}
GFC_REAL_10
rrspacing_r10 (GFC_REAL_10 s, int p)
{
int e;
GFC_REAL_10 x;
x = fabsl (s);
if (x == 0.)
return 0.;
frexpl (s, &e);
#if defined (HAVE_LDEXPL)
return ldexpl (x, p - e);
#else
return scalbnl (x, p - e);
#endif
}
long double
log2l (long double x)
{
if (isnanl (x))
return x;
if (x <= 0.0L)
{
if (x == 0.0L)
/* Return -Infinity. */
return - HUGE_VALL;
else
{
/* Return NaN. */
#if defined _MSC_VER || (defined __sgi && !defined __GNUC__)
static long double zero;
return zero / zero;
#else
return 0.0L / 0.0L;
#endif
}
}
/* Decompose x into
x = 2^e * y
where
e is an integer,
1/2 < y < 2.
Then log2(x) = e + log2(y) = e + log(y)/log(2). */
{
int e;
long double y;
y = frexpl (x, &e);
if (y < SQRT_HALF)
{
y = 2.0L * y;
e = e - 1;
}
return (long double) e + logl (y) * LOG2_INVERSE;
}
}
cl_object
_ecl_long_double_to_integer(long double d0)
{
const int fb = FIXNUM_BITS - 3;
int e;
long double d = frexpl(d0, &e);
if (e <= fb) {
return ecl_make_fixnum((cl_fixnum)d0);
} else if (e > LDBL_MANT_DIG) {
return ecl_ash(_ecl_long_double_to_integer(ldexp(d, LDBL_MANT_DIG)),
e - LDBL_MANT_DIG);
} else {
long double d1 = floorl(d = ldexpl(d, fb));
int newe = e - fb;
cl_object o = ecl_ash(_ecl_long_double_to_integer(d1), newe);
long double d2 = ldexpl(d - d1, newe);
if (d2) o = ecl_plus(o, _ecl_long_double_to_integer(d2));
return o;
}
}
int
main()
{
#if N & 1
long double value = 0;
#else
double value = 0;
#endif
#if N < 5
int exp = 0;
#endif
#if N == 1
return ldexpl(value, exp) != 0;
#endif
#if N == 2
return ldexp(value, exp) != 0;
#endif
#if N == 3
return frexpl(value, &exp) != 0;
#endif
#if N == 4
return frexp(value, &exp) != 0;
#endif
#if N == 5
return isnan(value);
#endif
#if N == 6
return isnan(value);
#endif
#if N == 7
return copysign(1.0, value) < 0;
#endif
#if N == 8
return signbit(value);
#endif
}
long double
logl (long double x)
{
long double z, y, w;
long double t;
int k, e;
/* Check for IEEE special cases. */
/* log(NaN) = NaN. */
if (isnanl (x))
{
return x;
}
/* log(0) = -infinity. */
if (x == 0.0L)
{
return -0.5L / ZERO;
}
/* log ( x < 0 ) = NaN */
if (x < 0.0L)
{
return (x - x) / ZERO;
}
/* log (infinity) */
if (x + x == x)
{
return x + x;
}
/* Extract exponent and reduce domain to 0.703125 <= u < 1.40625 */
x = frexpl (x, &e);
if (x < 0.703125L)
{
x += x;
e--;
}
/* On this interval the table is not used due to cancellation error. */
if ((x <= 1.0078125L) && (x >= 0.9921875L))
{
z = x - 1.0L;
k = 64;
t = 1.0L;
}
else
{
k = floorl ((x - 0.5L) * 128.0L);
t = 0.5L + k / 128.0L;
z = (x - t) / t;
}
/* Series expansion of log(1+z). */
w = z * z;
y = ((((((((((((l15 * z
+ l14) * z
+ l13) * z
+ l12) * z
+ l11) * z
+ l10) * z
+ l9) * z
+ l8) * z
+ l7) * z
+ l6) * z
+ l5) * z
+ l4) * z
+ l3) * z * w;
y -= 0.5 * w;
y += e * ln2b; /* Base 2 exponent offset times ln(2). */
y += z;
y += logtbl[k-26]; /* log(t) - (t-1) */
y += (t - 1.0L);
y += e * ln2a;
return y;
}
long double log10l(long double x)
{
long double y, z;
int e;
if (isnan(x))
return x;
if(x <= 0.0) {
if(x == 0.0)
return -1.0 / (x*x);
return (x - x) / 0.0;
}
if (x == INFINITY)
return INFINITY;
/* separate mantissa from exponent */
/* Note, frexp is used so that denormal numbers
* will be handled properly.
*/
x = frexpl(x, &e);
/* logarithm using log(x) = z + z**3 P(z)/Q(z),
* where z = 2(x-1)/x+1)
*/
if (e > 2 || e < -2) {
if (x < SQRTH) { /* 2(2x-1)/(2x+1) */
e -= 1;
z = x - 0.5;
y = 0.5 * z + 0.5;
} else { /* 2 (x-1)/(x+1) */
z = x - 0.5;
z -= 0.5;
y = 0.5 * x + 0.5;
}
x = z / y;
z = x*x;
y = x * (z * __polevll(z, R, 3) / __p1evll(z, S, 3));
goto done;
}
/* logarithm using log(1+x) = x - .5x**2 + x**3 P(x)/Q(x) */
if (x < SQRTH) {
e -= 1;
x = 2.0*x - 1.0;
} else {
x = x - 1.0;
}
z = x*x;
y = x * (z * __polevll(x, P, 6) / __p1evll(x, Q, 7));
y = y - 0.5*z;
done:
/* Multiply log of fraction by log10(e)
* and base 2 exponent by log10(2).
*
* ***CAUTION***
*
* This sequence of operations is critical and it may
* be horribly defeated by some compiler optimizers.
*/
z = y * (L10EB);
z += x * (L10EB);
z += e * (L102B);
z += y * (L10EA);
z += x * (L10EA);
z += e * (L102A);
return z;
}
void
domathl (void)
{
#ifndef NO_LONG_DOUBLE
long double f1;
long double f2;
int i1;
f1 = acosl(0.0);
fprintf( stdout, "acosl : %Lf\n", f1);
f1 = acoshl(0.0);
fprintf( stdout, "acoshl : %Lf\n", f1);
f1 = asinl(1.0);
fprintf( stdout, "asinl : %Lf\n", f1);
f1 = asinhl(1.0);
fprintf( stdout, "asinhl : %Lf\n", f1);
f1 = atanl(M_PI_4);
fprintf( stdout, "atanl : %Lf\n", f1);
f1 = atan2l(2.3, 2.3);
fprintf( stdout, "atan2l : %Lf\n", f1);
f1 = atanhl(1.0);
fprintf( stdout, "atanhl : %Lf\n", f1);
f1 = cbrtl(27.0);
fprintf( stdout, "cbrtl : %Lf\n", f1);
f1 = ceill(3.5);
fprintf( stdout, "ceill : %Lf\n", f1);
f1 = copysignl(3.5, -2.5);
fprintf( stdout, "copysignl : %Lf\n", f1);
f1 = cosl(M_PI_2);
fprintf( stdout, "cosl : %Lf\n", f1);
f1 = coshl(M_PI_2);
fprintf( stdout, "coshl : %Lf\n", f1);
f1 = erfl(42.0);
fprintf( stdout, "erfl : %Lf\n", f1);
f1 = erfcl(42.0);
fprintf( stdout, "erfcl : %Lf\n", f1);
f1 = expl(0.42);
fprintf( stdout, "expl : %Lf\n", f1);
f1 = exp2l(0.42);
fprintf( stdout, "exp2l : %Lf\n", f1);
f1 = expm1l(0.00042);
fprintf( stdout, "expm1l : %Lf\n", f1);
f1 = fabsl(-1.123);
fprintf( stdout, "fabsl : %Lf\n", f1);
f1 = fdiml(1.123, 2.123);
fprintf( stdout, "fdiml : %Lf\n", f1);
f1 = floorl(0.5);
fprintf( stdout, "floorl : %Lf\n", f1);
f1 = floorl(-0.5);
fprintf( stdout, "floorl : %Lf\n", f1);
f1 = fmal(2.1, 2.2, 3.01);
fprintf( stdout, "fmal : %Lf\n", f1);
f1 = fmaxl(-0.42, 0.42);
fprintf( stdout, "fmaxl : %Lf\n", f1);
f1 = fminl(-0.42, 0.42);
fprintf( stdout, "fminl : %Lf\n", f1);
f1 = fmodl(42.0, 3.0);
fprintf( stdout, "fmodl : %Lf\n", f1);
/* no type-specific variant */
i1 = fpclassify(1.0);
fprintf( stdout, "fpclassify : %d\n", i1);
f1 = frexpl(42.0, &i1);
fprintf( stdout, "frexpl : %Lf\n", f1);
f1 = hypotl(42.0, 42.0);
fprintf( stdout, "hypotl : %Lf\n", f1);
i1 = ilogbl(42.0);
fprintf( stdout, "ilogbl : %d\n", i1);
/* no type-specific variant */
i1 = isfinite(3.0);
fprintf( stdout, "isfinite : %d\n", i1);
/* no type-specific variant */
i1 = isgreater(3.0, 3.1);
fprintf( stdout, "isgreater : %d\n", i1);
/* no type-specific variant */
i1 = isgreaterequal(3.0, 3.1);
fprintf( stdout, "isgreaterequal : %d\n", i1);
/* no type-specific variant */
i1 = isinf(3.0);
fprintf( stdout, "isinf : %d\n", i1);
/* no type-specific variant */
i1 = isless(3.0, 3.1);
fprintf( stdout, "isless : %d\n", i1);
/* no type-specific variant */
i1 = islessequal(3.0, 3.1);
fprintf( stdout, "islessequal : %d\n", i1);
/* no type-specific variant */
i1 = islessgreater(3.0, 3.1);
fprintf( stdout, "islessgreater : %d\n", i1);
/* no type-specific variant */
i1 = isnan(0.0);
fprintf( stdout, "isnan : %d\n", i1);
/* no type-specific variant */
i1 = isnormal(3.0);
fprintf( stdout, "isnormal : %d\n", i1);
/* no type-specific variant */
f1 = isunordered(1.0, 2.0);
fprintf( stdout, "isunordered : %d\n", i1);
f1 = j0l(1.2);
fprintf( stdout, "j0l : %Lf\n", f1);
f1 = j1l(1.2);
fprintf( stdout, "j1l : %Lf\n", f1);
f1 = jnl(2,1.2);
fprintf( stdout, "jnl : %Lf\n", f1);
f1 = ldexpl(1.2,3);
fprintf( stdout, "ldexpl : %Lf\n", f1);
f1 = lgammal(42.0);
fprintf( stdout, "lgammal : %Lf\n", f1);
f1 = llrintl(-0.5);
fprintf( stdout, "llrintl : %Lf\n", f1);
f1 = llrintl(0.5);
fprintf( stdout, "llrintl : %Lf\n", f1);
f1 = llroundl(-0.5);
fprintf( stdout, "lroundl : %Lf\n", f1);
f1 = llroundl(0.5);
fprintf( stdout, "lroundl : %Lf\n", f1);
f1 = logl(42.0);
fprintf( stdout, "logl : %Lf\n", f1);
f1 = log10l(42.0);
fprintf( stdout, "log10l : %Lf\n", f1);
f1 = log1pl(42.0);
fprintf( stdout, "log1pl : %Lf\n", f1);
f1 = log2l(42.0);
fprintf( stdout, "log2l : %Lf\n", f1);
f1 = logbl(42.0);
fprintf( stdout, "logbl : %Lf\n", f1);
f1 = lrintl(-0.5);
fprintf( stdout, "lrintl : %Lf\n", f1);
f1 = lrintl(0.5);
fprintf( stdout, "lrintl : %Lf\n", f1);
f1 = lroundl(-0.5);
fprintf( stdout, "lroundl : %Lf\n", f1);
f1 = lroundl(0.5);
fprintf( stdout, "lroundl : %Lf\n", f1);
f1 = modfl(42.0,&f2);
fprintf( stdout, "lmodfl : %Lf\n", f1);
f1 = nanl("");
fprintf( stdout, "nanl : %Lf\n", f1);
f1 = nearbyintl(1.5);
fprintf( stdout, "nearbyintl : %Lf\n", f1);
f1 = nextafterl(1.5,2.0);
fprintf( stdout, "nextafterl : %Lf\n", f1);
f1 = powl(3.01, 2.0);
fprintf( stdout, "powl : %Lf\n", f1);
f1 = remainderl(3.01,2.0);
fprintf( stdout, "remainderl : %Lf\n", f1);
f1 = remquol(29.0,3.0,&i1);
fprintf( stdout, "remquol : %Lf\n", f1);
f1 = rintl(0.5);
fprintf( stdout, "rintl : %Lf\n", f1);
f1 = rintl(-0.5);
fprintf( stdout, "rintl : %Lf\n", f1);
f1 = roundl(0.5);
fprintf( stdout, "roundl : %Lf\n", f1);
f1 = roundl(-0.5);
fprintf( stdout, "roundl : %Lf\n", f1);
f1 = scalblnl(1.2,3);
fprintf( stdout, "scalblnl : %Lf\n", f1);
f1 = scalbnl(1.2,3);
fprintf( stdout, "scalbnl : %Lf\n", f1);
/* no type-specific variant */
i1 = signbit(1.0);
fprintf( stdout, "signbit : %i\n", i1);
f1 = sinl(M_PI_4);
fprintf( stdout, "sinl : %Lf\n", f1);
f1 = sinhl(M_PI_4);
fprintf( stdout, "sinhl : %Lf\n", f1);
f1 = sqrtl(9.0);
fprintf( stdout, "sqrtl : %Lf\n", f1);
f1 = tanl(M_PI_4);
fprintf( stdout, "tanl : %Lf\n", f1);
f1 = tanhl(M_PI_4);
fprintf( stdout, "tanhl : %Lf\n", f1);
f1 = tgammal(2.1);
fprintf( stdout, "tgammal : %Lf\n", f1);
f1 = truncl(3.5);
fprintf( stdout, "truncl : %Lf\n", f1);
f1 = y0l(1.2);
fprintf( stdout, "y0l : %Lf\n", f1);
f1 = y1l(1.2);
fprintf( stdout, "y1l : %Lf\n", f1);
f1 = ynl(3,1.2);
fprintf( stdout, "ynl : %Lf\n", f1);
#endif
}
int
main ()
{
int i;
long double x;
DECL_LONG_DOUBLE_ROUNDING
BEGIN_LONG_DOUBLE_ROUNDING ();
{ /* NaN. */
int exp = -9999;
long double mantissa;
x = 0.0L / 0.0L;
mantissa = frexpl (x, &exp);
ASSERT (isnanl (mantissa));
}
{ /* Positive infinity. */
int exp = -9999;
long double mantissa;
x = 1.0L / 0.0L;
mantissa = frexpl (x, &exp);
ASSERT (mantissa == x);
}
{ /* Negative infinity. */
int exp = -9999;
long double mantissa;
x = -1.0L / 0.0L;
mantissa = frexpl (x, &exp);
ASSERT (mantissa == x);
}
{ /* Positive zero. */
int exp = -9999;
long double mantissa;
x = 0.0L;
mantissa = frexpl (x, &exp);
ASSERT (exp == 0);
ASSERT (mantissa == x);
ASSERT (!signbit (mantissa));
}
{ /* Negative zero. */
int exp = -9999;
long double mantissa;
x = minus_zero;
mantissa = frexpl (x, &exp);
ASSERT (exp == 0);
ASSERT (mantissa == x);
ASSERT (signbit (mantissa));
}
for (i = 1, x = 1.0L; i <= LDBL_MAX_EXP; i++, x *= 2.0L)
{
int exp = -9999;
long double mantissa = frexpl (x, &exp);
ASSERT (exp == i);
ASSERT (mantissa == 0.5L);
}
for (i = 1, x = 1.0L; i >= MIN_NORMAL_EXP; i--, x *= 0.5L)
{
int exp = -9999;
long double mantissa = frexpl (x, &exp);
ASSERT (exp == i);
ASSERT (mantissa == 0.5L);
}
for (; i >= LDBL_MIN_EXP - 100 && x > 0.0L; i--, x *= 0.5L)
{
int exp = -9999;
long double mantissa = frexpl (x, &exp);
ASSERT (exp == i);
ASSERT (mantissa == 0.5L);
}
for (i = 1, x = -1.0L; i <= LDBL_MAX_EXP; i++, x *= 2.0L)
{
int exp = -9999;
long double mantissa = frexpl (x, &exp);
ASSERT (exp == i);
ASSERT (mantissa == -0.5L);
}
for (i = 1, x = -1.0L; i >= MIN_NORMAL_EXP; i--, x *= 0.5L)
{
int exp = -9999;
long double mantissa = frexpl (x, &exp);
ASSERT (exp == i);
ASSERT (mantissa == -0.5L);
}
for (; i >= LDBL_MIN_EXP - 100 && x < 0.0L; i--, x *= 0.5L)
{
int exp = -9999;
long double mantissa = frexpl (x, &exp);
ASSERT (exp == i);
ASSERT (mantissa == -0.5L);
}
for (i = 1, x = 1.01L; i <= LDBL_MAX_EXP; i++, x *= 2.0L)
{
int exp = -9999;
long double mantissa = frexpl (x, &exp);
ASSERT (exp == i);
ASSERT (mantissa == 0.505L);
}
for (i = 1, x = 1.01L; i >= MIN_NORMAL_EXP; i--, x *= 0.5L)
{
int exp = -9999;
long double mantissa = frexpl (x, &exp);
ASSERT (exp == i);
ASSERT (mantissa == 0.505L);
}
for (; i >= LDBL_MIN_EXP - 100 && x > 0.0L; i--, x *= 0.5L)
{
int exp = -9999;
long double mantissa = frexpl (x, &exp);
ASSERT (exp == i);
ASSERT (mantissa >= 0.5L);
ASSERT (mantissa < 1.0L);
ASSERT (mantissa == my_ldexp (x, - exp));
}
for (i = 1, x = 1.73205L; i <= LDBL_MAX_EXP; i++, x *= 2.0L)
{
int exp = -9999;
long double mantissa = frexpl (x, &exp);
ASSERT (exp == i);
ASSERT (mantissa == 0.866025L);
}
for (i = 1, x = 1.73205L; i >= MIN_NORMAL_EXP; i--, x *= 0.5L)
{
int exp = -9999;
long double mantissa = frexpl (x, &exp);
ASSERT (exp == i);
ASSERT (mantissa == 0.866025L);
}
for (; i >= LDBL_MIN_EXP - 100 && x > 0.0L; i--, x *= 0.5L)
{
int exp = -9999;
long double mantissa = frexpl (x, &exp);
ASSERT (exp == i || exp == i + 1);
ASSERT (mantissa >= 0.5L);
ASSERT (mantissa < 1.0L);
ASSERT (mantissa == my_ldexp (x, - exp));
}
return 0;
}
/*
* Fused multiply-add: Compute x * y + z with a single rounding error.
*
* We use scaling to avoid overflow/underflow, along with the
* canonical precision-doubling technique adapted from:
*
* Dekker, T. A Floating-Point Technique for Extending the
* Available Precision. Numer. Math. 18, 224-242 (1971).
*/
long double
fmal(long double x, long double y, long double z)
{
long double xs, ys, zs, adj;
struct dd xy, r;
int oround;
int ex, ey, ez;
int spread;
/*
* Handle special cases. The order of operations and the particular
* return values here are crucial in handling special cases involving
* infinities, NaNs, overflows, and signed zeroes correctly.
*/
if (x == 0.0 || y == 0.0)
return (x * y + z);
if (z == 0.0)
return (x * y);
if (!isfinite(x) || !isfinite(y))
return (x * y + z);
if (!isfinite(z))
return (z);
xs = frexpl(x, &ex);
ys = frexpl(y, &ey);
zs = frexpl(z, &ez);
oround = fegetround();
spread = ex + ey - ez;
/*
* If x * y and z are many orders of magnitude apart, the scaling
* will overflow, so we handle these cases specially. Rounding
* modes other than FE_TONEAREST are painful.
*/
if (spread < -LDBL_MANT_DIG) {
feraiseexcept(FE_INEXACT);
if (!isnormal(z))
feraiseexcept(FE_UNDERFLOW);
switch (oround) {
case FE_TONEAREST:
return (z);
case FE_TOWARDZERO:
if (x > 0.0 ^ y < 0.0 ^ z < 0.0)
return (z);
else
return (nextafterl(z, 0));
case FE_DOWNWARD:
if (x > 0.0 ^ y < 0.0)
return (z);
else
return (nextafterl(z, -INFINITY));
default: /* FE_UPWARD */
if (x > 0.0 ^ y < 0.0)
return (nextafterl(z, INFINITY));
else
return (z);
}
}
if (spread <= LDBL_MANT_DIG * 2)
zs = ldexpl(zs, -spread);
else
zs = copysignl(LDBL_MIN, zs);
fesetround(FE_TONEAREST);
/* work around clang bug 8100 */
volatile long double vxs = xs;
/*
* Basic approach for round-to-nearest:
*
* (xy.hi, xy.lo) = x * y (exact)
* (r.hi, r.lo) = xy.hi + z (exact)
* adj = xy.lo + r.lo (inexact; low bit is sticky)
* result = r.hi + adj (correctly rounded)
*/
xy = dd_mul(vxs, ys);
r = dd_add(xy.hi, zs);
spread = ex + ey;
if (r.hi == 0.0) {
/*
* When the addends cancel to 0, ensure that the result has
* the correct sign.
*/
fesetround(oround);
volatile long double vzs = zs; /* XXX gcc CSE bug workaround */
return (xy.hi + vzs + ldexpl(xy.lo, spread));
}
if (oround != FE_TONEAREST) {
/*
* There is no need to worry about double rounding in directed
* rounding modes.
*/
fesetround(oround);
/* work around clang bug 8100 */
volatile long double vrlo = r.lo;
adj = vrlo + xy.lo;
return (ldexpl(r.hi + adj, spread));
}
adj = add_adjusted(r.lo, xy.lo);
if (spread + ilogbl(r.hi) > -16383)
return (ldexpl(r.hi + adj, spread));
else
return (add_and_denormalize(r.hi, adj, spread));
}
long double
log10l(long double x)
{
long double y;
volatile long double z;
int e;
if( isnan(x) )
return(x);
/* Test for domain */
if( x <= 0.0L )
{
if( x == 0.0L )
return (-1.0L / (x - x));
else
return (x - x) / (x - x);
}
if( x == INFINITY )
return(INFINITY);
/* separate mantissa from exponent */
/* Note, frexp is used so that denormal numbers
* will be handled properly.
*/
x = frexpl( x, &e );
/* logarithm using log(x) = z + z**3 P(z)/Q(z),
* where z = 2(x-1)/x+1)
*/
if( (e > 2) || (e < -2) )
{
if( x < SQRTH )
{ /* 2( 2x-1 )/( 2x+1 ) */
e -= 1;
z = x - 0.5L;
y = 0.5L * z + 0.5L;
}
else
{ /* 2 (x-1)/(x+1) */
z = x - 0.5L;
z -= 0.5L;
y = 0.5L * x + 0.5L;
}
x = z / y;
z = x*x;
y = x * ( z * __polevll( z, R, 3 ) / __p1evll( z, S, 3 ) );
goto done;
}
/* logarithm using log(1+x) = x - .5x**2 + x**3 P(x)/Q(x) */
if( x < SQRTH )
{
e -= 1;
x = ldexpl( x, 1 ) - 1.0L; /* 2x - 1 */
}
else
{
x = x - 1.0L;
}
z = x*x;
y = x * ( z * __polevll( x, P, 6 ) / __p1evll( x, Q, 7 ) );
y = y - ldexpl( z, -1 ); /* -0.5x^2 + ... */
done:
/* Multiply log of fraction by log10(e)
* and base 2 exponent by log10(2).
*
* ***CAUTION***
*
* This sequence of operations is critical and it may
* be horribly defeated by some compiler optimizers.
*/
z = y * (L10EB);
z += x * (L10EB);
z += e * (L102B);
z += y * (L10EA);
z += x * (L10EA);
z += e * (L102A);
return( z );
}
cl_object
cl_integer_decode_float(cl_object x)
{
const cl_env_ptr the_env = ecl_process_env();
int e, s = 1;
switch (ecl_t_of(x)) {
#ifdef ECL_LONG_FLOAT
case t_longfloat: {
long double d = ecl_long_float(x);
if (signbit(d)) {
s = -1;
d = -d;
}
if (d == 0.0) {
e = 0;
x = ecl_make_fixnum(0);
} else {
d = frexpl(d, &e);
x = _ecl_long_double_to_integer(ldexpl(d, LDBL_MANT_DIG));
e -= LDBL_MANT_DIG;
}
break;
}
#endif
case t_doublefloat: {
double d = ecl_double_float(x);
if (signbit(d)) {
s = -1;
d = -d;
}
if (d == 0.0) {
e = 0;
x = ecl_make_fixnum(0);
} else {
d = frexp(d, &e);
x = _ecl_double_to_integer(ldexp(d, DBL_MANT_DIG));
e -= DBL_MANT_DIG;
}
break;
}
case t_singlefloat: {
float d = ecl_single_float(x);
if (signbit(d)) {
s = -1;
d = -d;
}
if (d == 0.0) {
e = 0;
x = ecl_make_fixnum(0);
} else {
d = frexpf(d, &e);
x = _ecl_double_to_integer(ldexp(d, FLT_MANT_DIG));
e -= FLT_MANT_DIG;
}
break;
}
default:
FEwrong_type_nth_arg(ecl_make_fixnum(/*INTEGER-DECODE-FLOAT*/438),1,x,ecl_make_fixnum(/*FLOAT*/374));
}
ecl_return3(the_env, x, ecl_make_fixnum(e), ecl_make_fixnum(s));
}
long double
log1pl(long double xm1)
{
long double x, y, z, r, s;
ieee_quad_shape_type u;
int32_t hx;
int e;
/* Test for NaN or infinity input. */
u.value = xm1;
hx = u.parts32.mswhi;
if (hx >= 0x7fff0000)
return xm1;
/* log1p(+- 0) = +- 0. */
if (((hx & 0x7fffffff) == 0)
&& (u.parts32.mswlo | u.parts32.lswhi | u.parts32.lswlo) == 0)
return xm1;
x = xm1 + 1.0L;
/* log1p(-1) = -inf */
if (x <= 0.0L)
{
if (x == 0.0L)
return (-1.0L / (x - x));
else
return (zero / (x - x));
}
/* Separate mantissa from exponent. */
/* Use frexp used so that denormal numbers will be handled properly. */
x = frexpl (x, &e);
/* Logarithm using log(x) = z + z^3 P(z^2)/Q(z^2),
where z = 2(x-1)/x+1). */
if ((e > 2) || (e < -2))
{
if (x < sqrth)
{ /* 2( 2x-1 )/( 2x+1 ) */
e -= 1;
z = x - 0.5L;
y = 0.5L * z + 0.5L;
}
else
{ /* 2 (x-1)/(x+1) */
z = x - 0.5L;
z -= 0.5L;
y = 0.5L * x + 0.5L;
}
x = z / y;
z = x * x;
r = ((((R5 * z
+ R4) * z
+ R3) * z
+ R2) * z
+ R1) * z
+ R0;
s = (((((z
+ S5) * z
+ S4) * z
+ S3) * z
+ S2) * z
+ S1) * z
+ S0;
z = x * (z * r / s);
z = z + e * C2;
z = z + x;
z = z + e * C1;
return (z);
}
/* Logarithm using log(1+x) = x - .5x^2 + x^3 P(x)/Q(x). */
if (x < sqrth)
{
e -= 1;
if (e != 0)
x = 2.0L * x - 1.0L; /* 2x - 1 */
else
x = xm1;
}
else
{
if (e != 0)
x = x - 1.0L;
else
x = xm1;
}
z = x * x;
r = (((((((((((P12 * x
+ P11) * x
+ P10) * x
+ P9) * x
+ P8) * x
+ P7) * x
+ P6) * x
+ P5) * x
+ P4) * x
+ P3) * x
+ P2) * x
+ P1) * x
+ P0;
s = (((((((((((x
+ Q11) * x
+ Q10) * x
+ Q9) * x
+ Q8) * x
+ Q7) * x
+ Q6) * x
+ Q5) * x
+ Q4) * x
+ Q3) * x
+ Q2) * x
+ Q1) * x
+ Q0;
y = x * (z * r / s);
y = y + e * C2;
z = y - 0.5L * z;
z = z + x;
z = z + e * C1;
return (z);
}
/*
* Fused multiply-add: Compute x * y + z with a single rounding error.
*
* We use scaling to avoid overflow/underflow, along with the
* canonical precision-doubling technique adapted from:
*
* Dekker, T. A Floating-Point Technique for Extending the
* Available Precision. Numer. Math. 18, 224-242 (1971).
*/
long double
fmal(long double x, long double y, long double z)
{
#if LDBL_MANT_DIG == 64
static const long double split = 0x1p32L + 1.0;
#elif LDBL_MANT_DIG == 113
static const long double split = 0x1p57L + 1.0;
#endif
long double xs, ys, zs;
long double c, cc, hx, hy, p, q, tx, ty;
long double r, rr, s;
int oround;
int ex, ey, ez;
int spread;
if (z == 0.0)
return (x * y);
if (x == 0.0 || y == 0.0)
return (x * y + z);
/* Results of frexp() are undefined for these cases. */
if (!isfinite(x) || !isfinite(y) || !isfinite(z))
return (x * y + z);
xs = frexpl(x, &ex);
ys = frexpl(y, &ey);
zs = frexpl(z, &ez);
oround = fegetround();
spread = ex + ey - ez;
/*
* If x * y and z are many orders of magnitude apart, the scaling
* will overflow, so we handle these cases specially. Rounding
* modes other than FE_TONEAREST are painful.
*/
if (spread > LDBL_MANT_DIG * 2) {
fenv_t env;
feraiseexcept(FE_INEXACT);
switch(oround) {
case FE_TONEAREST:
return (x * y);
case FE_TOWARDZERO:
if (x > 0.0 ^ y < 0.0 ^ z < 0.0)
return (x * y);
feholdexcept(&env);
r = x * y;
if (!fetestexcept(FE_INEXACT))
r = nextafterl(r, 0);
feupdateenv(&env);
return (r);
case FE_DOWNWARD:
if (z > 0.0)
return (x * y);
feholdexcept(&env);
r = x * y;
if (!fetestexcept(FE_INEXACT))
r = nextafterl(r, -INFINITY);
feupdateenv(&env);
return (r);
default: /* FE_UPWARD */
if (z < 0.0)
return (x * y);
feholdexcept(&env);
r = x * y;
if (!fetestexcept(FE_INEXACT))
r = nextafterl(r, INFINITY);
feupdateenv(&env);
return (r);
}
}
if (spread < -LDBL_MANT_DIG) {
feraiseexcept(FE_INEXACT);
if (!isnormal(z))
feraiseexcept(FE_UNDERFLOW);
switch (oround) {
case FE_TONEAREST:
return (z);
case FE_TOWARDZERO:
if (x > 0.0 ^ y < 0.0 ^ z < 0.0)
return (z);
else
return (nextafterl(z, 0));
case FE_DOWNWARD:
if (x > 0.0 ^ y < 0.0)
return (z);
else
return (nextafterl(z, -INFINITY));
default: /* FE_UPWARD */
if (x > 0.0 ^ y < 0.0)
return (nextafterl(z, INFINITY));
else
return (z);
}
}
/*
* Use Dekker's algorithm to perform the multiplication and
* subsequent addition in twice the machine precision.
* Arrange so that x * y = c + cc, and x * y + z = r + rr.
*/
fesetround(FE_TONEAREST);
p = xs * split;
hx = xs - p;
hx += p;
tx = xs - hx;
p = ys * split;
hy = ys - p;
hy += p;
ty = ys - hy;
p = hx * hy;
q = hx * ty + tx * hy;
c = p + q;
cc = p - c + q + tx * ty;
zs = ldexpl(zs, -spread);
r = c + zs;
s = r - c;
rr = (c - (r - s)) + (zs - s) + cc;
spread = ex + ey;
if (spread + ilogbl(r) > -16383) {
fesetround(oround);
r = r + rr;
} else {
/*
* The result is subnormal, so we round before scaling to
* avoid double rounding.
*/
p = ldexpl(copysignl(0x1p-16382L, r), -spread);
c = r + p;
s = c - r;
cc = (r - (c - s)) + (p - s) + rr;
fesetround(oround);
r = (c + cc) - p;
}
return (ldexpl(r, spread));
}
cl_object
cl_rational(cl_object x)
{
double d;
AGAIN:
switch (ecl_t_of(x)) {
case t_fixnum:
case t_bignum:
case t_ratio:
break;
case t_singlefloat:
d = ecl_single_float(x);
goto GO_ON;
case t_doublefloat:
d = ecl_double_float(x);
GO_ON: if (d == 0) {
x = ecl_make_fixnum(0);
} else {
int e;
d = frexp(d, &e);
e -= DBL_MANT_DIG;
x = _ecl_double_to_integer(ldexp(d, DBL_MANT_DIG));
if (e != 0) {
x = ecl_times(ecl_expt(ecl_make_fixnum(FLT_RADIX),
ecl_make_fixnum(e)),
x);
}
}
break;
#ifdef ECL_LONG_FLOAT
case t_longfloat: {
long double d = ecl_long_float(x);
if (d == 0) {
x = ecl_make_fixnum(0);
} else {
int e;
d = frexpl(d, &e);
e -= LDBL_MANT_DIG;
d = ldexpl(d, LDBL_MANT_DIG);
x = _ecl_long_double_to_integer(d);
if (e != 0) {
x = ecl_times(ecl_expt(ecl_make_fixnum(FLT_RADIX),
ecl_make_fixnum(e)),
x);
}
}
break;
}
#endif
default:
x = ecl_type_error(ECL_SYM("RATIONAL",687),"argument",x,ECL_SYM("NUMBER",606));
goto AGAIN;
}
{
#line 871
const cl_env_ptr the_env = ecl_process_env();
#line 871
#line 871
cl_object __value0 = x;
#line 871
the_env->nvalues = 1;
#line 871
return __value0;
#line 871
}
}
int
main()
{
long double x, y, y0, z, f, x00, y00;
int i, j, e, e0;
int errfr, errld, errfl, underexp, err, errth, e00;
long double frexpl(), ldexpl(), floorl();
/*
if( 1 )
goto flrtst;
*/
printf( "Testing frexpl() and ldexpl().\n" );
errth = 0.0L;
errfr = 0;
errld = 0;
underexp = 0;
f = 1.0L;
x00 = 2.0L;
y00 = 0.5L;
e00 = 2;
for( j=0; j<20; j++ )
{
if( j == 10 )
{
f = 1.0L;
x00 = 2.0L;
e00 = 1;
/* Find 2**(2**14) / 2 */
for( i=0; i<13; i++ )
{
x00 *= x00;
e00 += e00;
}
y00 = x00/2.0L;
x00 = x00 * y00;
e00 += e00;
y00 = 0.5L;
}
x = x00 * f;
y0 = y00 * f;
e0 = e00;
#if 1
/* If ldexp, frexp support denormal numbers, this should work. */
for( i=0; i<16448; i++ )
#else
for( i=0; i<16383; i++ )
#endif
{
x /= 2.0L;
e0 -= 1;
if( x == 0.0L )
{
if( f == 1.0L )
underexp = e0;
y0 = 0.0L;
e0 = 0;
}
y = frexpl( x, &e );
if( (e0 < -16383) && (e != e0) )
{
if( e == (e0 - 1) )
{
e += 1;
y /= 2.0L;
}
if( e == (e0 + 1) )
{
e -= 1;
y *= 2.0L;
}
}
err = y - y0;
if( y0 != 0.0L )
err /= y0;
if( err < 0.0L )
err = -err;
if( e0 > -1023 )
errth = 0.0L;
else
{ /* Denormal numbers may have rounding errors */
if( e0 == -16383 )
{
errth = 2.0L * MACHEPL;
}
else
{
errth *= 2.0L;
}
}
if( (x != 0.0L) && ((err > errth) || (e != e0)) )
{
printf( "Test %d: ", j+1 );
printf( " frexpl( %.20Le) =?= %.20Le * 2**%d;", x, y, e );
printf( " should be %.20Le * 2**%d\n", y0, e0 );
errfr += 1;
}
y = ldexpl( x, 1-e0 );
err = y - 1.0L;
if( err < 0.0L )
err = -err;
if( (err > errth) && ((x == 0.0L) && (y != 0.0L)) )
{
printf( "Test %d: ", j+1 );
printf( "ldexpl( %.15Le, %d ) =?= %.15Le;", x, 1-e0, y );
if( x != 0.0L )
printf( " should be %.15Le\n", f );
else
printf( " should be %.15Le\n", 0.0L );
errld += 1;
}
if( x == 0.0L )
{
break;
}
}
f = f * 1.08005973889L;
}
if( (errld == 0) && (errfr == 0) )
{
printf( "No errors found.\n" );
}
/*flrtst:*/
printf( "Testing floorl().\n" );
errfl = 0;
f = 1.0L/MACHEPL;
x00 = 1.0L;
for( j=0; j<57; j++ )
{
x = x00 - 1.0L;
for( i=0; i<128; i++ )
{
y = floorl(x);
if( y != x )
{
flierr( x, y, j );
errfl += 1;
}
/* Warning! the if() statement is compiler dependent,
* since x-0.49 may be held in extra precision accumulator
* so would never compare equal to x! The subroutine call
* y = floor() forces z to be stored as a double and reloaded
* for the if() statement.
*/
z = x - 0.49L;
y = floorl(z);
if( z == x )
break;
if( y != (x - 1.0L) )
{
flierr( z, y, j );
errfl += 1;
}
z = x + 0.49L;
y = floorl(z);
if( z != x )
{
if( y != x )
{
flierr( z, y, j );
errfl += 1;
}
}
x = -x;
y = floorl(x);
if( z != x )
{
if( y != x )
{
flierr( x, y, j );
errfl += 1;
}
}
z = x + 0.49L;
y = floorl(z);
if( z != x )
{
if( y != x )
{
flierr( z, y, j );
errfl += 1;
}
}
z = x - 0.49L;
y = floorl(z);
if( z != x )
{
if( y != (x - 1.0L) )
{
flierr( z, y, j );
errfl += 1;
}
}
x = -x;
x += 1.0L;
}
x00 = x00 + x00;
}
y = floorl(0.0L);
if( y != 0.0L )
{
flierr( 0.0L, y, 57 );
errfl += 1;
}
y = floorl(-0.0L);
if( y != 0.0L )
{
flierr( -0.0L, y, 58 );
errfl += 1;
}
y = floorl(-1.0L);
if( y != -1.0L )
{
flierr( -1.0L, y, 59 );
errfl += 1;
}
y = floorl(-0.1L);
if( y != -1.0l )
{
flierr( -0.1L, y, 60 );
errfl += 1;
}
if( errfl == 0 )
printf( "No errors found in floorl().\n" );
exit(0);
return 0;
}
static long double powil(long double x, int nn)
{
long double ww, y;
long double s;
int n, e, sign, lx;
if (nn == 0)
return 1.0;
if (nn < 0) {
sign = -1;
n = -nn;
} else {
sign = 1;
n = nn;
}
/* Overflow detection */
/* Calculate approximate logarithm of answer */
s = x;
s = frexpl( s, &lx);
e = (lx - 1)*n;
if ((e == 0) || (e > 64) || (e < -64)) {
s = (s - 7.0710678118654752e-1L) / (s + 7.0710678118654752e-1L);
s = (2.9142135623730950L * s - 0.5 + lx) * nn * LOGE2L;
} else {
s = LOGE2L * e;
}
if (s > MAXLOGL)
return huge * huge; /* overflow */
if (s < MINLOGL)
return twom10000 * twom10000; /* underflow */
/* Handle tiny denormal answer, but with less accuracy
* since roundoff error in 1.0/x will be amplified.
* The precise demarcation should be the gradual underflow threshold.
*/
if (s < -MAXLOGL+2.0) {
x = 1.0/x;
sign = -sign;
}
/* First bit of the power */
if (n & 1)
y = x;
else
y = 1.0;
ww = x;
n >>= 1;
while (n) {
ww = ww * ww; /* arg to the 2-to-the-kth power */
if (n & 1) /* if that bit is set, then include in product */
y *= ww;
n >>= 1;
}
if (sign < 0)
y = 1.0/y;
return y;
}
long double log1pl(long double xm1)
{
long double x, y, z;
int e;
if (isnan(xm1))
return xm1;
if (xm1 == INFINITY)
return xm1;
if (xm1 == 0.0)
return xm1;
x = xm1 + 1.0;
/* Test for domain errors. */
if (x <= 0.0) {
if (x == 0.0)
return -1/x; /* -inf with divbyzero */
return 0/0.0f; /* nan with invalid */
}
/* Separate mantissa from exponent.
Use frexp so that denormal numbers will be handled properly. */
x = frexpl(x, &e);
/* logarithm using log(x) = z + z^3 P(z)/Q(z),
where z = 2(x-1)/x+1) */
if (e > 2 || e < -2) {
if (x < SQRTH) { /* 2(2x-1)/(2x+1) */
e -= 1;
z = x - 0.5;
y = 0.5 * z + 0.5;
} else { /* 2 (x-1)/(x+1) */
z = x - 0.5;
z -= 0.5;
y = 0.5 * x + 0.5;
}
x = z / y;
z = x*x;
z = x * (z * __polevll(z, R, 3) / __p1evll(z, S, 3));
z = z + e * C2;
z = z + x;
z = z + e * C1;
return z;
}
/* logarithm using log(1+x) = x - .5x**2 + x**3 P(x)/Q(x) */
if (x < SQRTH) {
e -= 1;
if (e != 0)
x = 2.0 * x - 1.0;
else
x = xm1;
} else {
if (e != 0)
x = x - 1.0;
else
x = xm1;
}
z = x*x;
y = x * (z * __polevll(x, P, 6) / __p1evll(x, Q, 6));
y = y + e * C2;
z = y - 0.5 * z;
z = z + x;
z = z + e * C1;
return z;
}
long double
log10l(long double x)
{
long double z;
long double y;
int e;
int64_t hx, lx;
/* Test for domain */
GET_LDOUBLE_WORDS64 (hx, lx, x);
if (((hx & 0x7fffffffffffffffLL) | lx) == 0)
return (-1.0L / (x - x));
if (hx < 0)
return (x - x) / (x - x);
if (hx >= 0x7fff000000000000LL)
return (x + x);
/* separate mantissa from exponent */
/* Note, frexp is used so that denormal numbers
* will be handled properly.
*/
x = frexpl (x, &e);
/* logarithm using log(x) = z + z**3 P(z)/Q(z),
* where z = 2(x-1)/x+1)
*/
if ((e > 2) || (e < -2))
{
if (x < SQRTH)
{ /* 2( 2x-1 )/( 2x+1 ) */
e -= 1;
z = x - 0.5L;
y = 0.5L * z + 0.5L;
}
else
{ /* 2 (x-1)/(x+1) */
z = x - 0.5L;
z -= 0.5L;
y = 0.5L * x + 0.5L;
}
x = z / y;
z = x * x;
y = x * (z * neval (z, R, 5) / deval (z, S, 5));
goto done;
}
/* logarithm using log(1+x) = x - .5x**2 + x**3 P(x)/Q(x) */
if (x < SQRTH)
{
e -= 1;
x = 2.0 * x - 1.0L; /* 2x - 1 */
}
else
{
x = x - 1.0L;
}
z = x * x;
y = x * (z * neval (x, P, 12) / deval (x, Q, 11));
y = y - 0.5 * z;
done:
/* Multiply log of fraction by log10(e)
* and base 2 exponent by log10(2).
*/
z = y * L10EB;
z += x * L10EB;
z += e * L102B;
z += y * L10EA;
z += x * L10EA;
z += e * L102A;
return (z);
}
void regressMinRelError_fr(int n, int m, mpfr_t **x, mpfr_t *result) {
int m0 = n * 3, n0 = m + 2 * n, i, j;
mpfr_t **a0, *c0, *result0;
int in0[m0];
a0 = malloc(sizeof(mpfr_t *) * m0);
for(i=0;i<m0;i++) {
a0[i] = calloc(n0+1, sizeof(mpfr_t));
for(j=0;j<n0+1;j++) mpfr_zinit(a0[i][j]);
}
c0 = calloc(n0+1, sizeof(mpfr_t));
result0 = calloc(n0+1, sizeof(mpfr_t));
for(j=0;j<n0+1;j++) {
mpfr_zinit(c0[j]);
mpfr_zinit(result0[j]);
}
for(i=0;i<n;i++) {
long double ld = mpfr_get_ld(x[m][i], GMP_RNDN);
if (ld < DBL_MIN) ld = 1;
#if 1
mpfr_set_ld(c0[m+i +1], 1.0/fabsl(ld), GMP_RNDN);
mpfr_set_ld(c0[m+n+i+1], 1.0/fabsl(ld), GMP_RNDN);
#else
int e;
frexpl(ld, &e);
ld = 1.0 / ldexpl(1.0, e);
mpfr_set_ld(c0[m+i +1], ld, GMP_RNDN);
mpfr_set_ld(c0[m+n+i+1], ld, GMP_RNDN);
#endif
mpfr_set_d(a0[i*3+0][m+i+1], 1, GMP_RNDN);
in0[i*3+0] = GEQ;
mpfr_set_d(a0[i*3+1][m+n+i+1], 1, GMP_RNDN);
in0[i*3+1] = GEQ;
for(j=0;j<m;j++) {
mpfr_set(a0[i*3+2][j+1], x[j][i], GMP_RNDN);
}
mpfr_set_d(a0[i*3+2][m+i+1], 1, GMP_RNDN);
mpfr_set_d(a0[i*3+2][m+n+i+1], -1, GMP_RNDN);
in0[i*3+2] = EQU;
mpfr_set(a0[i*3+2][0], x[m][i], GMP_RNDN);
mpfr_neg(a0[i*3+2][0], a0[i*3+2][0], GMP_RNDN);
}
int status = solve_fr(result0, n0, m0, a0, in0, c0);
if (status == NOT_FEASIBLE) {
printf("not feasible\n");
} else {
if (status == MAXIMIZABLE_TO_INFINITY) printf("maximizable to inf\n");
}
for(i=0;i<m;i++) {
mpfr_set(result[i], result0[i+1], GMP_RNDN);
}
free(result0);
free(c0);
}
long double powl(long double x, long double y)
{
/* double F, Fa, Fb, G, Ga, Gb, H, Ha, Hb */
int i, nflg, iyflg, yoddint;
long e;
volatile long double z=0;
long double w=0, W=0, Wa=0, Wb=0, ya=0, yb=0, u=0;
/* make sure no invalid exception is raised by nan comparision */
if (isnan(x)) {
if (!isnan(y) && y == 0.0)
return 1.0;
return x;
}
if (isnan(y)) {
if (x == 1.0)
return 1.0;
return y;
}
if (x == 1.0)
return 1.0; /* 1**y = 1, even if y is nan */
if (x == -1.0 && !isfinite(y))
return 1.0; /* -1**inf = 1 */
if (y == 0.0)
return 1.0; /* x**0 = 1, even if x is nan */
if (y == 1.0)
return x;
if (y >= LDBL_MAX) {
if (x > 1.0 || x < -1.0)
return INFINITY;
if (x != 0.0)
return 0.0;
}
if (y <= -LDBL_MAX) {
if (x > 1.0 || x < -1.0)
return 0.0;
if (x != 0.0 || y == -INFINITY)
return INFINITY;
}
if (x >= LDBL_MAX) {
if (y > 0.0)
return INFINITY;
return 0.0;
}
w = floorl(y);
/* Set iyflg to 1 if y is an integer. */
iyflg = 0;
if (w == y)
iyflg = 1;
/* Test for odd integer y. */
yoddint = 0;
if (iyflg) {
ya = fabsl(y);
ya = floorl(0.5 * ya);
yb = 0.5 * fabsl(w);
if( ya != yb )
yoddint = 1;
}
if (x <= -LDBL_MAX) {
if (y > 0.0) {
if (yoddint)
return -INFINITY;
return INFINITY;
}
if (y < 0.0) {
if (yoddint)
return -0.0;
return 0.0;
}
}
nflg = 0; /* (x<0)**(odd int) */
if (x <= 0.0) {
if (x == 0.0) {
if (y < 0.0) {
if (signbit(x) && yoddint)
/* (-0.0)**(-odd int) = -inf, divbyzero */
return -1.0/0.0;
/* (+-0.0)**(negative) = inf, divbyzero */
return 1.0/0.0;
}
if (signbit(x) && yoddint)
return -0.0;
return 0.0;
}
if (iyflg == 0)
return (x - x) / (x - x); /* (x<0)**(non-int) is NaN */
/* (x<0)**(integer) */
if (yoddint)
nflg = 1; /* negate result */
x = -x;
}
/* (+integer)**(integer) */
if (iyflg && floorl(x) == x && fabsl(y) < 32768.0) {
w = powil(x, (int)y);
return nflg ? -w : w;
}
/* separate significand from exponent */
x = frexpl(x, &i);
e = i;
/* find significand in antilog table A[] */
i = 1;
if (x <= A[17])
i = 17;
if (x <= A[i+8])
i += 8;
if (x <= A[i+4])
i += 4;
if (x <= A[i+2])
i += 2;
if (x >= A[1])
i = -1;
i += 1;
/* Find (x - A[i])/A[i]
* in order to compute log(x/A[i]):
*
* log(x) = log( a x/a ) = log(a) + log(x/a)
*
* log(x/a) = log(1+v), v = x/a - 1 = (x-a)/a
*/
x -= A[i];
x -= B[i/2];
x /= A[i];
/* rational approximation for log(1+v):
*
* log(1+v) = v - v**2/2 + v**3 P(v) / Q(v)
*/
z = x*x;
w = x * (z * __polevll(x, P, 3) / __p1evll(x, Q, 3));
w = w - 0.5*z;
/* Convert to base 2 logarithm:
* multiply by log2(e) = 1 + LOG2EA
*/
z = LOG2EA * w;
z += w;
z += LOG2EA * x;
z += x;
/* Compute exponent term of the base 2 logarithm. */
w = -i;
w /= NXT;
w += e;
/* Now base 2 log of x is w + z. */
/* Multiply base 2 log by y, in extended precision. */
/* separate y into large part ya
* and small part yb less than 1/NXT
*/
ya = reducl(y);
yb = y - ya;
/* (w+z)(ya+yb)
* = w*ya + w*yb + z*y
*/
F = z * y + w * yb;
Fa = reducl(F);
Fb = F - Fa;
G = Fa + w * ya;
Ga = reducl(G);
Gb = G - Ga;
H = Fb + Gb;
Ha = reducl(H);
w = (Ga + Ha) * NXT;
/* Test the power of 2 for overflow */
if (w > MEXP)
return huge * huge; /* overflow */
if (w < MNEXP)
return twom10000 * twom10000; /* underflow */
e = w;
Hb = H - Ha;
if (Hb > 0.0) {
e += 1;
Hb -= 1.0/NXT; /*0.0625L;*/
}
/* Now the product y * log2(x) = Hb + e/NXT.
*
* Compute base 2 exponential of Hb,
* where -0.0625 <= Hb <= 0.
*/
z = Hb * __polevll(Hb, R, 6); /* z = 2**Hb - 1 */
/* Express e/NXT as an integer plus a negative number of (1/NXT)ths.
* Find lookup table entry for the fractional power of 2.
*/
if (e < 0)
i = 0;
else
i = 1;
i = e/NXT + i;
e = NXT*i - e;
w = A[e];
z = w * z; /* 2**-e * ( 1 + (2**Hb-1) ) */
z = z + w;
z = scalbnl(z, i); /* multiply by integer power of 2 */
if (nflg)
z = -z;
return z;
}
GFC_REAL_10
set_exponent_r10 (GFC_REAL_10 s, GFC_INTEGER_4 i)
{
int dummy_exp;
return scalbnl (frexpl (s, &dummy_exp), i);
}