int isinf(double d)
{
#if HAVE_FP_CLASS
int fpclass = fp_class(d);
#else
int fpclass = fp_class_d(d);
#endif
if (fpclass == FP_POS_INF)
return 1;
if (fpclass == FP_NEG_INF)
return -1;
return 0;
}
_f_int4 _FP_CLASS_I4_R(_f_real8 x)
{
#if defined(__mips) || (defined(_LITTLE_ENDIAN) && defined(__sv2))
int x_result;
x_result = fp_class_d(x);
switch(x_result) {
case FP_NEG_ZERO: {
return (FOR_K_FP_NEG_ZERO);
break;
}
case FP_POS_ZERO: {
return (FOR_K_FP_POS_ZERO);
break;
}
case FP_NEG_DENORM: {
return (FOR_K_FP_NEG_DENORM);
break;
}
case FP_POS_DENORM: {
return (FOR_K_FP_POS_DENORM);
break;
}
case FP_NEG_INF: {
return (FOR_K_FP_NEG_INF);
break;
}
case FP_SNAN: {
return (FOR_K_FP_SNAN);
break;
}
case FP_QNAN: {
return (FOR_K_FP_QNAN);
break;
}
case FP_POS_INF: {
return (FOR_K_FP_POS_INF);
break;
}
case FP_NEG_NORM: {
return (FOR_K_FP_NEG_NORM);
break;
}
case FP_POS_NORM: {
return (FOR_K_FP_POS_NORM);
break;
}
default: {
return -1;
break;
}
} /* Switch(x_result) */
#elif (defined(_CRAYIEEE) && !defined(__mips)) || defined(_SOLARIS)
/* if we must call fpclassify */
int x_result;
union _uval_r x_val;
x_result = fpclassify(x);
x_val.dwd = x;
switch(x_result) {
case FP_ZERO: {
/* Test for pos/neg */
if(x_val.parts.sign) {
return (FOR_K_FP_NEG_ZERO);
} else {
return (FOR_K_FP_POS_ZERO);
}
break;
}
case FP_SUBNORMAL: {
/* Test for pos/neg */
if(x_val.parts.sign) {
return (FOR_K_FP_NEG_DENORM);
} else {
return (FOR_K_FP_POS_DENORM);
}
break;
}
case FP_INFINITE: {
/* Test for pos/neg */
if(x_val.parts.sign) {
return (FOR_K_FP_NEG_INF);
} else {
return (FOR_K_FP_POS_INF);
}
break;
}
case FP_NAN: {
#ifdef _CRAYT3E /* on the t3e, all NaNs are signal NaNs */
return (FOR_K_FP_SNAN);
#else
/* test for quiet/signal on others */
if(x_val.parts.q_bit) {
return (FOR_K_FP_QNAN);
} else {
return (FOR_K_FP_SNAN);
}
#endif /* #ifdef _CRAYT3E */
break;
}
case FP_NORMAL: {
/* Test for pos/neg */
if(x_val.parts.sign) {
return (FOR_K_FP_NEG_NORM);
} else {
return (FOR_K_FP_POS_NORM);
}
break;
}
default: {
return -1;
break;
}
} /* End switch(x_result); */
#elif defined(_LITTLE_ENDIAN) && !defined(__sv2)
union _uval_r x_val;
x_val.dwd = x;
if(x_val.parts.exp == 0)
{
if(x_val.parts.up == 0 &&
x_val.parts.lo == 0 &&
x_val.parts.q_bit == 0)
{
if(x_val.parts.sign)
return (FOR_K_FP_NEG_ZERO);
else
return (FOR_K_FP_POS_ZERO);
}
else
{
if(x_val.parts.sign)
return (FOR_K_FP_NEG_DENORM);
else
return (FOR_K_FP_POS_DENORM);
}
}
else if(x_val.parts.exp == IEEE_64_EXPO_MAX)
{
if(x_val.parts.up == 0 &&
x_val.parts.lo == 0 &&
x_val.parts.q_bit == 0)
{
if(x_val.parts.sign)
return (FOR_K_FP_NEG_INF);
else
return (FOR_K_FP_POS_INF);
}
else
{
if(x_val.parts.q_bit)
return (FOR_K_FP_QNAN);
else
return (FOR_K_FP_SNAN);
}
}
else if(x_val.parts.sign)
return (FOR_K_FP_NEG_NORM);
else
return (FOR_K_FP_POS_NORM);
#endif /* #if defined(__mips) ... #elif defined(_CRAYT3E) && defined(__mips) */
return -1;
}
static int wrt_ESQ (unit *ftnunit, ufloat *p, int w, int d, int e, ftnlen notused_len, char symbol, flag doblank)
{
char *s = NULL;
int dp, absdp, sign, i;
long double dd;
char buffer[100];
int left_digits = 1; /* maximum value */
int spaces_needed;
dd = p->pld;
dp = d + left_digits;
if (dp > 0) {
s = qecvt_mp (dd, dp, &dp, &sign, buffer);
if (fp_class_d (dd) == FP_POS_INF)
s = "Inf";
else if (fp_class_d (dd) == FP_NEG_INF)
s = "-Inf";
}
if (s && !isdigit (*s)) { /* just print Infinity, Nan, etc. */
PUT ((i = (int) strlen (s)), 0, s);
if (doblank && w > i)
PUT (w - i, ' ', NULL);/* pad to proper width */
} else { /* do the normal thing */
dp = dp - left_digits; /* interpret string s as x.xxxxxxx */
if (dd != 0) { /* sjc #2113 */
dp -= ftnunit->f77scale;
absdp = dp < 0 ? -dp : dp;
} else
absdp = dp = 0;
if ( e == 0 && absdp > 999 ) return(100);
spaces_needed = e ? e + 3 : 5;
if (sign || ftnunit->f77cplus) spaces_needed++;
spaces_needed += d + left_digits;
if ((w < spaces_needed)
|| (e == 1 && absdp > 9)
|| (e == 2 && absdp > 99)) {
PUT (w, '*', NULL);
return (0);
}
if (doblank && w > spaces_needed)
PUT (w - spaces_needed, ' ', NULL);
if (sign)
PUT (1, (char) (dd==0 ? ' ' : '-'), NULL);
else if (ftnunit->f77cplus)
PUT (1, '+', NULL);
PUT (1, s[0], NULL);
PUT (1, '.', NULL);
PUT (d, 0, &s[1]);
if ((e > 0) || (absdp < 100)) PUT (1, symbol, NULL);
PUT (1, (char) (dp < 0 ? '-' : '+'), NULL);
if (!e) e = absdp > 99 ? 3 : 2;
while (e--) {
PUT (1, (char) ((i = absdp / exp10(e)) + '0'), NULL);
absdp -= i * exp10(e);
}
}
return (0);
}
static int wrt_EN (unit *ftnunit, ufloat *p, int w, int d, int e, ftnlen len, char symbol, flag doblank)
{
char *s = NULL;
int dp, absdp, sign, i;
double dd;
char buffer[100];
int left_digits = 3; /* maximum value */
int spaces_needed;
if (len == sizeof (float))
dd = p->pf;
else
dd = p->pd;
dp = d + left_digits;
if (dp > 0) {
s = ecvt_mp (dd, dp, &dp, &sign, buffer);
if (fp_class_d (dd) == FP_POS_INF)
s = "Inf";
else if (fp_class_d (dd) == FP_NEG_INF)
s = "-Inf";
}
if (s && !isdigit (*s)) { /* just print Infinity, Nan, etc. */
PUT ((i = (int) strlen (s)), 0, s);
if (doblank && w > i) PUT (w - i, ' ', NULL);/* pad to proper width */
} else { /* do the normal thing */
if (dd != 0) {
if ( dp > 0 ) {
left_digits = (dp-1) % 3 + 1;
} else {
left_digits = 3 + dp % 3;
}
if ( left_digits < 3 ) { /* maybe roundoff error */
dp = d + left_digits; /* try again with smaller number of significant digits */
s = ecvt_mp (dd, dp, &dp, &sign, buffer);
if ( dp > 0 ) {
left_digits = (dp-1) % 3 + 1;
} else {
left_digits = 3 + dp % 3;
}
}
dp = dp - left_digits; /* interpret string s as x.xxxxxxxE+3n */
/* or xx.xxxxxxxE+3n */
/* or xxx.xxxxxxxE+3n */
} else {
dp = 0;
left_digits = 1;
}
if (dd != 0) { /* sjc #2113 */
dp -= ftnunit->f77scale;
absdp = dp < 0 ? -dp : dp;
} else
absdp = dp = 0;
if ( e == 0 && absdp > 999 ) return(100);
spaces_needed = e ? e + 3 : 5;
if (sign || ftnunit->f77cplus) spaces_needed++;
spaces_needed += d + left_digits;
if ((w < spaces_needed)
|| (e == 1 && absdp > 9)
|| (e == 2 && absdp > 99)) {
PUT (w, '*', NULL);
return (0);
}
if (doblank && w > spaces_needed)
PUT (w - spaces_needed, ' ', NULL);
if (sign)
PUT (1, (char) (dd==0 ? ' ' : '-'), NULL);
else if (ftnunit->f77cplus)
PUT (1, '+', NULL);
PUT (left_digits, 0, s);
PUT (1, '.', NULL);
PUT (d, 0, &s[left_digits]);
if ((e > 0) || (absdp < 100)) PUT (1, symbol, NULL);
PUT (1, (char) (dp < 0 ? '-' : '+'), NULL);
if (!e) e = absdp > 99 ? 3 : 2;
while (e--) {
PUT (1, (char) ((i = absdp / exp10(e)) + '0'), NULL);
absdp -= i * exp10(e);
}
}
return (0);
}
static int
wrt_EQ (unit *ftnunit, ufloat *p, int w, int d, int e, ftnlen notused_len, char symbol, flag doblank)
{
char *s = NULL;
int dp, absdp, sign, i, delta, pow10, leading0;
long double dd;
char buffer[100];
dd = p->pld;
if (w == 0) {
w = 40;
d = 31;
e = 2;
}
if (exceed_length(ftnunit, w)) return(110);
dp = ftnunit->f77scale > 0 ? d + 1 : d + ftnunit->f77scale;
if (dp > 0) {
s = qecvt_mp (dd, dp, &dp, &sign, buffer);
if (fp_class_d (dd) == FP_POS_INF)
s = "Inf";
else if (fp_class_d (dd) == FP_NEG_INF)
s = "-Inf";
}
if (s && !isdigit (*s)) { /* just print Infinity, Nan, etc. */
PUT ((i = (int) strlen (s)), 0, s);
if (doblank && w > i)
PUT (w - i, ' ', NULL);/* pad to proper width */
} else { /* do the normal thing */
if (dd != 0) { /* sjc #2113 */
dp -= ftnunit->f77scale;
absdp = dp < 0 ? -dp : dp;
} else
absdp = dp = 0;
delta = e ? e + 3 : 5;
if (sign || ftnunit->f77cplus)
delta++; /* AGC 10/29/86 */
if (ftnunit->f77scale > 0)
delta++;
if ((w > delta + d) && (ftnunit->f77scale <= 0)) {
delta++;
leading0 = 1;
} else
leading0 = 0;
if ((w < delta + d)
|| (e == 1 && absdp > 9)
|| (e == 2 && absdp > 99)
|| (ftnunit->f77scale <= 0 && ftnunit->f77scale <= -d)
|| (ftnunit->f77scale > 0 && ftnunit->f77scale > d + 1)) {
PUT (w, '*', NULL);
return (0);
}
if (doblank && w > (delta + d))
PUT (w - (delta + d), ' ', NULL);
if (sign)
PUT (1, (char) (dd==0 ? ' ' : '-'), NULL);
else if (ftnunit->f77cplus)
PUT (1, '+', NULL);
if (ftnunit->f77scale <= 0) {
if (leading0)
PUT (1, '0', NULL);
PUT (1, '.', NULL);
PUT (-ftnunit->f77scale, '0', NULL);
if ((d + ftnunit->f77scale) > 0)
PUT (d + ftnunit->f77scale, 0, s);
} else {
PUT (ftnunit->f77scale, 0, s);
PUT (1, '.', NULL);
/* 6/26/89
* fix bug 4547
*/
if (d >= ftnunit->f77scale)
PUT (d - ftnunit->f77scale + 1, 0, s + ftnunit->f77scale);
}
if ((e > 0) || (absdp < 100))
PUT (1, symbol, NULL);
PUT (1, (char) (dp < 0 ? '-' : '+'), NULL);
if (!e)
e = absdp > 99 ? 3 : 2;
for (pow10 = 1, i = e; --i; pow10 *= 10);
while (e--) {
PUT (1, (char) ((i = absdp / pow10) + '0'), NULL);
absdp -= i * pow10;
pow10 /= 10;
}
}
return (0);
}
static int
wrt_E (unit *ftnunit, ufloat *p, int w, int d, int e, ftnlen len, char symbol, flag doblank)
{
char *s = NULL;
int dp, absdp, sign, i, delta, pow10, leading0;
double dd;
char buffer[100];
if (len == sizeof (float))
dd = p->pf;
else
dd = p->pd;
if (w == 0) {
if (len == 4) {
w = 15;
d = 7;
} else {
w = 25;
d = 16;
}
e = 2;
}
if (exceed_length(ftnunit, w)) return(110);
dp = ftnunit->f77scale > 0 ? d + 1 : d + ftnunit->f77scale;
/*
* BN 8559 . There is a problem with ecvt ( from libc ) and if the number dd
* passed to it is Infinity -ve or positive and dp ( the length of the
* string passed back ) is less than 8, then the string "Infinity" gets
* truncated. Rather than try to fix this in ecvt , have akludge here to
* take care of the problem. Test to see if dd is inf. and if it is set the
* string s = "infinity"
* ---ravi--- 10/28/91
if ( dp > 0 ) s=ecvt_mp( dd ,dp,&dp,&sign, buffer);
*/
if (dp > 0) {
s = ecvt_mp (dd, dp, &dp, &sign, buffer);
if (fp_class_d (dd) == FP_POS_INF)
s = "Inf";
else if (fp_class_d (dd) == FP_NEG_INF)
s = "-Inf";
}
/* Fix BN 11222.
* Make sure s is not NULL before dereferencing it.
* ---ravi---1/27/92
*/
/* if (!isdigit(*s)) { *//* just print Infinity, Nan, etc. */
if (s && !isdigit (*s)) { /* just print Infinity, Nan, etc. */
PUT ((i = (int) strlen (s)), 0, s);
if (doblank && w > i)
PUT (w - i, ' ', NULL);/* pad to proper width */
} else { /* do the normal thing */
if (dd != 0) { /* sjc #2113 */
dp -= ftnunit->f77scale;
absdp = dp < 0 ? -dp : dp;
} else
absdp = dp = 0;
delta = e ? e + 3 : 5;
if (sign || ftnunit->f77cplus)
delta++; /* AGC 10/29/86 */
if (ftnunit->f77scale > 0)
delta++;
if ((w > delta + d) && (ftnunit->f77scale <= 0)) {
delta++;
leading0 = 1;
} else
leading0 = 0;
if ((w < delta + d)
|| (e == 1 && absdp > 9)
|| (e == 2 && absdp > 99)
|| (ftnunit->f77scale <= 0 && ftnunit->f77scale <= -d)
|| (ftnunit->f77scale > 0 && ftnunit->f77scale > d + 1)) {
PUT (w, '*', NULL);
return (0);
}
if (doblank && w > (delta + d))
PUT (w - (delta + d), ' ', NULL);
if (sign)
PUT (1, (char) (dd==0 ? ' ' : '-'), NULL);
else if (ftnunit->f77cplus)
PUT (1, '+', NULL);
if (ftnunit->f77scale <= 0) {
if (leading0)
PUT (1, '0', NULL);
PUT (1, '.', NULL);
PUT (-ftnunit->f77scale, '0', NULL);
if ((d + ftnunit->f77scale) > 0)
PUT (d + ftnunit->f77scale, 0, s);
} else {
PUT (ftnunit->f77scale, 0, s);
PUT (1, '.', NULL);
/* 6/26/89
* fix bug 4547
*/
if (d >= ftnunit->f77scale)
PUT (d - ftnunit->f77scale + 1, 0, s + ftnunit->f77scale);
}
if ((e > 0) || (absdp < 100))
PUT (1, symbol, NULL);
PUT (1, (char) (dp < 0 ? '-' : '+'), NULL);
if (!e) {
/* For the common case this is much faster than the general
algorithm
*/
if (absdp > 99.0) {
PUT (1, (char) ((i = absdp / 1e2 ) + '0'), NULL);
absdp -= i * 1e2;
}
PUT (1, (char) ((i = absdp / 1e1) + '0'), NULL);
absdp -= i * 1e1;
PUT (1, (char) ((i = absdp) + '0'), NULL);
}
else {
for (pow10 = 1, i = e; --i; pow10 *= 10);
while (e--) {
PUT (1, (char) ((i = absdp / pow10) + '0'), NULL);
absdp -= i * pow10;
pow10 /= 10;
}
}
}
return (0);
}
/* _IEEE_EXPONENT_I2_D - IEEE EXPONENT returns the exponent part of the
* 128-bit argument in 16-bit integer.
*/
_f_int2
_IEEE_EXPONENT_I2_D(_f_real16 x)
{
union _ieee_ldouble {
_f_real16 ldword;
_f_real8 dbword[2];
};
#if __BYTE_ORDER == __LITTLE_ENDIAN
const int dbword_hi = 1;
const int dbword_lo = 0;
#else
const int dbword_hi = 0;
const int dbword_lo = 1;
#endif
union _ieee_double {
_f_real8 dword;
_f_int8 lword;
unsigned long long ull;
struct {
#if __BYTE_ORDER == __LITTLE_ENDIAN
unsigned int mantissa2 : IEEE_64_MANT_BTS2;
unsigned int mantissa1 : IEEE_64_MANT_BTS1;
unsigned int exponent : IEEE_64_EXPO_BITS;
unsigned int sign : 1;
#else
unsigned int sign : 1;
unsigned int exponent : IEEE_64_EXPO_BITS;
unsigned int mantissa1 : IEEE_64_MANT_BTS1;
unsigned int mantissa2 : IEEE_64_MANT_BTS2;
#endif
} parts;
};
_f_int2 iresult = 0;
switch(fp_class_l(x)) {
case FP_SNAN:
case FP_QNAN:
case FP_POS_INF:
case FP_NEG_INF:
{
/* return positive huge for NaN or infinity. */
return(HUGE_INT2_F90);
}
case FP_POS_NORM:
case FP_NEG_NORM:
{
#pragma weak logbl
return((_f_int2) logbl(x));
}
case FP_POS_DENORM:
case FP_NEG_DENORM:
{
/* return exponent from first 64-bit double. */
union _ieee_ldouble x_val;
x_val.ldword = x;
switch(fp_class_d(x_val.dbword[dbword_hi])) {
case FP_POS_NORM:
case FP_NEG_NORM:
{
union _ieee_double db_x;
db_x.dword = x_val.dbword[dbword_hi];
return((_f_int2)(db_x.parts.exponent -
IEEE_64_EXPO_BIAS));
}
case FP_POS_DENORM:
case FP_NEG_DENORM:
{
union _ieee_double db_x;
db_x.dword = x_val.dbword[dbword_hi];
db_x.ull =
IEEE_64_MANTISSA & db_x.ull;
return((_f_int2)(-IEEE_64_EXPO_BIAS -
(_leadz8(db_x.ull) +
IEEE_64_EXPO_BITS)));
}
}
}
case FP_POS_ZERO:
case FP_NEG_ZERO:
{
/* return negative huge for zero. */
return(-HUGE_INT2_F90);
}
}
return(iresult);
}
/* _IEEE_EXPONENT_I2_R - IEEE EXPONENT returns the exponent part of the
* 64-bit argument in 16-bit integer.
*/
_f_int2
_IEEE_EXPONENT_I2_R(_f_real8 x)
{
union _ieee_double {
_f_real8 dword;
_f_int8 lword;
unsigned long long ull;
struct {
#if __BYTE_ORDER == __LITTLE_ENDIAN
unsigned int mantissa2 : IEEE_64_MANT_BTS2;
unsigned int mantissa1 : IEEE_64_MANT_BTS1;
unsigned int exponent : IEEE_64_EXPO_BITS;
unsigned int sign : 1;
#else
unsigned int sign : 1;
unsigned int exponent : IEEE_64_EXPO_BITS;
unsigned int mantissa1 : IEEE_64_MANT_BTS1;
unsigned int mantissa2 : IEEE_64_MANT_BTS2;
#endif
} parts;
};
_f_int2 iresult = 0;
switch(fp_class_d(x)) {
case FP_SNAN:
case FP_QNAN:
case FP_POS_INF:
case FP_NEG_INF:
{
/* return positive huge for NaN or infinity. */
return(HUGE_INT2_F90);
}
case FP_POS_NORM:
case FP_NEG_NORM:
{
union _ieee_double x_val;
x_val.dword = x;
return((_f_int2)(x_val.parts.exponent -
IEEE_64_EXPO_BIAS));
}
case FP_POS_DENORM:
case FP_NEG_DENORM:
{
union _ieee_double x_val;
x_val.dword = x;
x_val.ull = IEEE_64_MANTISSA & x_val.ull;;
/* _leadz returns number of zeros before first 1
* in mantissa. Add 8 to exclude exponent bits,
* but count sign bit since implicit bit needs to
* be counted.
*/
return((_f_int2)(-IEEE_64_EXPO_BIAS -
(_leadz8(x_val.ull) +
IEEE_64_EXPO_BITS)));
}
case FP_POS_ZERO:
case FP_NEG_ZERO:
{
/* return negative huge for zero. */
return(-HUGE_INT2_F90);
}
}
return(iresult);
}