float
_IEEE_EXPONENT_H_H(float x)
{
union _ieee_float {
float dword;
int lword;
struct {
#if defined(_LITTLE_ENDIAN)
unsigned int mantissa : IEEE_32_MANT_BITS;
unsigned int exponent : IEEE_32_EXPO_BITS;
unsigned int sign : 1;
#else
unsigned int sign : 1;
unsigned int exponent : IEEE_32_EXPO_BITS;
unsigned int mantissa : IEEE_32_MANT_BITS;
#endif
} parts;
};
switch (_fpclassifyf(x)) {
case FP_NAN:
return(x);
case FP_INFINITE:
{
union _ieee_float x_val;
x_val.lword = IEEE_32_INFINITY;
return(x_val.dword);
}
case FP_NORMAL:
{
union _ieee_float x_val;
x_val.dword = x;
return(x_val.parts.exponent - IEEE_32_EXPO_BIAS);
}
case FP_SUBNORMAL:
{
union _ieee_float x_val;
x_val.dword = x;
/* _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(-IEEE_32_EXPO_BIAS -
(_leadz(x_val.parts.mantissa) - 32) +
IEEE_32_EXPO_BITS);
}
case FP_ZERO:
{
union _ieee_float x_val;
int j;
/* raise divide-by-zero exception */
j = FE_DIVBYZERO;
feraiseexcept(j);
/* return negative infinity */
x_val.dword = IEEE_32_INFINITY;
x_val.parts.sign = 1;
return(x_val.dword);
}
}
}
long double
_IEEE_EXPONENT_D_H(float x)
{
/* Union defined to work with IEEE 128 bit floating point. */
union _ieee_ldouble {
long double dword;
long lword[2];
struct {
unsigned int sign : 1;
unsigned int exponent : IEEE_128_EXPO_BITS;
unsigned int mantissa_up : IEEE_128_MANT_BITS_UP;
unsigned int mantissa_low : IEEE_128_MANT_BITS_LOW;
} lparts;
};
union _ieee_fdouble {
float dwrd;
int lwrd;
struct {
#if __BYTE_ORDER == __LITTLE_ENDIAN
unsigned int mantissa : IEEE_32_MANT_BITS;
unsigned int expon : IEEE_32_EXPO_BITS;
unsigned int sgn : 1;
#else
unsigned int sgn : 1;
unsigned int expon : IEEE_32_EXPO_BITS;
unsigned int mantissa : IEEE_32_MANT_BITS;
#endif
} parts;
};
switch (_fpclassifyf(x)) {
case FP_NAN:
{
union _ieee_ldouble x_val;
x_val.dword = _DBL_NaN;
return(x_val.dword);
}
case FP_INFINITE:
{
union _ieee_ldouble x_val;
x_val.lword[0] = INFINITY_128_UP;
x_val.lword[1] = INFINITY_128_LOW;
x_val.lparts.sign = 0;
return(x_val.dword);
}
case FP_NORMAL:
{
union _ieee_fdouble x_val;
x_val.dwrd = x;
return(x_val.parts.expon - IEEE_32_EXPO_BIAS);
}
case FP_SUBNORMAL:
{
union _ieee_fdouble x_val;
int y;
x_val.dwrd = x;
/* _leadz returns number of zeros before first 1
* in mantissa. Add IEEE_32_EXPO_BITS to exclude
* exponent bits, but count sign bit since
* implicit bit needs to be counted.
*/
return(-IEEE_32_EXPO_BIAS -
(_leadz(x_val.parts.mantissa) - 32) +
IEEE_32_EXPO_BITS);
}
case FP_ZERO:
{
int j;
union _ieee_ldouble x_val;
/* raise divide-by-zero exception */
j = FE_DIVBYZERO;
feraiseexcept(j);
/* return negative infinity */
x_val.lword[0] = INFINITY_128_UP;
x_val.lword[1] = INFINITY_128_LOW;
x_val.lparts.sign = 1;
return(x_val.dword);
}
}
}
float
_IEEE_EXPONENT_H_R(double x)
{
/* Union defined to work with IEEE 32 bit floating point. */
union _ieee_float {
float dword;
int lword;
struct {
#if defined(_LITTLE_ENDIAN)
unsigned int mantissa : IEEE_32_MANT_BITS;
unsigned int exponent : IEEE_32_EXPO_BITS;
unsigned int sign : 1;
#else
unsigned int sign : 1;
unsigned int exponent : IEEE_32_EXPO_BITS;
unsigned int mantissa : IEEE_32_MANT_BITS;
#endif
} fparts;
};
union _ieee_double {
double dwrd;
long long lwrd;
struct {
#if defined(_LITTLE_ENDIAN)
unsigned int mantissa : IEEE_64_MANT_BITS;
unsigned int expon : IEEE_64_EXPO_BITS;
unsigned int sgn : 1;
#else
unsigned int sgn : 1;
unsigned int expon : IEEE_64_EXPO_BITS;
unsigned int mantissa : IEEE_64_MANT_BITS;
#endif
} parts;
};
switch (_fpclassify(x)) {
case FP_NAN:
{
union _ieee_float x_val;
x_val.lword = _HALF_NaN;
return(x_val.dword);
}
case FP_INFINITE:
{
union _ieee_float x_val;
x_val.lword = IEEE_32_INFINITY;
return(x_val.dword);
}
case FP_NORMAL:
{
union _ieee_double x_val;
x_val.dwrd = x;
return(x_val.parts.expon - IEEE_64_EXPO_BIAS);
}
case FP_SUBNORMAL:
{
union _ieee_double x_val;
int y;
x_val.dwrd = x;
/* _leadz returns number of zeros before first 1
* in mantissa. Add IEEE_64_EXPO_BITS to exclude
* exponent bits, but count sign bit since
* implicit bit needs to be counted.
*/
return(-IEEE_64_EXPO_BIAS -
_leadz(x_val.parts.mantissa) +
IEEE_64_EXPO_BITS);
}
case FP_ZERO:
{
int j;
union _ieee_float x_val;
/* raise divide-by-zero exception */
j = FE_DIVBYZERO;
feraiseexcept(j);
/* return negative infinity */
x_val.lword = IEEE_32_INFINITY;
x_val.fparts.sign = 1;
return(x_val.dword);
}
}
}
static void
_rb(
FIOSPTR css, /* Current Fortran I/O state */
unit *cup, /* Unit pointer */
_f_int *recmode, /* Mode */
gfptr_t bloc, /* Beginning location */
gfptr_t eloc, /* Ending location */
type_packet *tip) /* Type information packet */
{
register int bytshft;
register int mode;
register long bytes;
register long elsize;
register long itemlen;
register long items;
register long stat;
register ftype_t type90;
int state;
char *uda, *udax;
#ifdef _CRAYT3D
register short shared;
register long ntot;
register long numleft;
long shrd[MAXSH];
#endif
if (cup->useq == 0) /* If direct access file */
_ferr(css, FEBIONDA, "BUFFER IN");
if (cup->ufmt) /* If formatted file */
_ferr(css, FEBIONFM, "BUFFER IN");
if (cup->uerr && !cup->unitchk)
_ferr(css, cup->uffsw.sw_error);
/*
* This check taken out temporarily because we'd like to be able to
* follow an ENDFILE statement or a READ which encounters an endfile
* record with a BUFFER IN statement. The sticky EOF principle should
* permit such a BUFFER IN to simply return an EOF status. But what
* really happens is the preceding ENDFILE or READ statement sets
* cup->uend, triggering an error here. We really need a flag to
* store the status of the previous BUFFER IN/OUT statement which is
* separate from cup->uend.
*
* if (cup->uend && !cup->unitchk)
* _ferr(css, FERDPEOF);
*/
cup->unitchk = 0;
cup->uerr = 0;
elsize = tip->elsize; /* Data size in bytes */
type90 = tip->type90;
/*
* Adjust the word count depending on the type.
*/
bytshft = ((sizeof(elsize) << 3) - 1) - _leadz(elsize); /* log2(elsize) */
if (type90 == DVTYPE_ASCII) { /* If character item */
uda = _fcdtocp(bloc.fcd);
udax = _fcdtocp(eloc.fcd);
itemlen = _fcdlen (eloc.fcd);
}
else {
#ifdef _CRAYT3D
shared = 0;
if (_issddptr(bloc.v)) {
int *tmpptr;
/* Shared data */
if (!_issddptr(eloc.v)) {
_ferr(css, FEINTUNK);
}
shared = 1;
ntot = 0;
if ((cup->ufs == FS_FDC) &&
(cup->uflagword & FFC_ASYNC)) {
/* When we can do I/O from shared memory */
/* we can support this. */
_ferr(css, FESHRSUP);
}
/*
* When compiler spr 76429 (on T3D) is closed, we can try replacing
* the lines that use tmpptr with this.
* items = _sdd_read_offset((void *)eloc.v) -
* _sdd_read_offset((void *)bloc.v) + 1;
*/
uda = bloc.v; /* temporary */
udax = eloc.v;
tmpptr = (int *)((int)udax & 0x7fffffffffffffff);
items = *(tmpptr + 1);
tmpptr = (int *)((int)uda & 0x7fffffffffffffff);
items = items - *(tmpptr + 1) + 1;
}
else
#endif /* _CRAYT3D */
{
uda = bloc.v;
udax = eloc.v;
}
itemlen = elsize;
}
#ifdef _CRAYT3D
if (shared) {
bytes = items << bytshft;
}
else
#endif
{
bytes = (udax - uda) + itemlen;
items = bytes >> bytshft;
}
if (bytes < 0)
_ferr(css, FEBIOFWA, "BUFFER IN");
mode = (*recmode < 0) ? PARTIAL : FULL;
cup->urecmode = mode;
cup->uwrt = 0;
state = CNT;
if ((items << bytshft) != bytes)
_ferr(css, FEBIOFWD);
#ifdef _CRAYT3D
if ( !shared && cup->uasync ) {
#else
if (cup->uasync) {
#endif
int ubc = 0;
WAITIO(cup, _ferr(css, cup->uffsw.sw_error));
#if defined(_UNICOS) || defined(NUMERIC_DATA_CONVERSION_ENABLED)
/*
* Pad word-aligned numeric data on word boundaries within
* the record for CRI and some foreign data formats.
*/
if ((cup->urecpos & cup->ualignmask) != 0 &&
type90 != DVTYPE_ASCII &&
elsize > 4 ) {
int padubc;
register int pbytes;
int padval;
COMPADD(cup, pbytes, padubc, padval);
if (pbytes != 0) {
stat = XRCALL(cup->ufp.fdc, readrtn)
cup->ufp.fdc,
WPTR2BP(&padval),
pbytes,
&cup->uffsw,
PARTIAL,
&padubc);
if (stat != pbytes ||
FFSTAT(cup->uffsw) != FFCNT) {
cup->uerr = 1;
goto badpart;
}
cup->urecpos += (stat << 3) - padubc;
}
}