freebsd-skq/contrib/libf2c/libI77/wref.c

307 lines
4.8 KiB
C

#include "f2c.h"
#include "fio.h"
#ifndef VAX
#include <ctype.h>
#endif
#undef abs
#undef min
#undef max
#include <stdlib.h>
#include <string.h>
#include "fmt.h"
#include "fp.h"
int
wrt_E (ufloat * p, int w, int d, int e, ftnlen len)
{
char buf[FMAX + EXPMAXDIGS + 4], *s, *se;
int d1, delta, e1, i, sign, signspace;
double dd;
#ifdef WANT_LEAD_0
int insert0 = 0;
#endif
#ifndef VAX
int e0 = e;
#endif
if (e <= 0)
e = 2;
if (f__scale)
{
if (f__scale >= d + 2 || f__scale <= -d)
goto nogood;
}
if (f__scale <= 0)
--d;
if (len == sizeof (real))
dd = p->pf;
else
dd = p->pd;
if (dd < 0.)
{
signspace = sign = 1;
dd = -dd;
}
else
{
sign = 0;
signspace = (int) f__cplus;
#ifndef VAX
if (!dd)
dd = 0.; /* avoid -0 */
#endif
}
delta = w - (2 /* for the . and the d adjustment above */
+ 2 /* for the E+ */ + signspace + d + e);
#ifdef WANT_LEAD_0
if (f__scale <= 0 && delta > 0)
{
delta--;
insert0 = 1;
}
else
#endif
if (delta < 0)
{
nogood:
while (--w >= 0)
PUT ('*');
return (0);
}
if (f__scale < 0)
d += f__scale;
if (d > FMAX)
{
d1 = d - FMAX;
d = FMAX;
}
else
d1 = 0;
sprintf (buf, "%#.*E", d, dd);
#ifndef VAX
/* check for NaN, Infinity */
if (!isdigit ((unsigned char) buf[0]))
{
switch (buf[0])
{
case 'n':
case 'N':
signspace = 0; /* no sign for NaNs */
}
delta = w - strlen (buf) - signspace;
if (delta < 0)
goto nogood;
while (--delta >= 0)
PUT (' ');
if (signspace)
PUT (sign ? '-' : '+');
for (s = buf; *s; s++)
PUT (*s);
return 0;
}
#endif
se = buf + d + 3;
#ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */
if (f__scale != 1 && dd)
sprintf (se, "%+.2d", atoi (se) + 1 - f__scale);
#else
if (dd)
sprintf (se, "%+.2d", atoi (se) + 1 - f__scale);
else
strcpy (se, "+00");
#endif
s = ++se;
if (e < 2)
{
if (*s != '0')
goto nogood;
}
#ifndef VAX
/* accommodate 3 significant digits in exponent */
if (s[2])
{
#ifdef Pedantic
if (!e0 && !s[3])
for (s -= 2, e1 = 2; s[0] = s[1]; s++);
/* Pedantic gives the behavior that Fortran 77 specifies, */
/* i.e., requires that E be specified for exponent fields */
/* of more than 3 digits. With Pedantic undefined, we get */
/* the behavior that Cray displays -- you get a bigger */
/* exponent field if it fits. */
#else
if (!e0)
{
for (s -= 2, e1 = 2; (s[0] = s[1]); s++)
#ifdef CRAY
delta--;
if ((delta += 4) < 0)
goto nogood
#endif
;
}
#endif
else if (e0 >= 0)
goto shift;
else
e1 = e;
}
else
shift:
#endif
for (s += 2, e1 = 2; *s; ++e1, ++s)
if (e1 >= e)
goto nogood;
while (--delta >= 0)
PUT (' ');
if (signspace)
PUT (sign ? '-' : '+');
s = buf;
i = f__scale;
if (f__scale <= 0)
{
#ifdef WANT_LEAD_0
if (insert0)
PUT ('0');
#endif
PUT ('.');
for (; i < 0; ++i)
PUT ('0');
PUT (*s);
s += 2;
}
else if (f__scale > 1)
{
PUT (*s);
s += 2;
while (--i > 0)
PUT (*s++);
PUT ('.');
}
if (d1)
{
se -= 2;
while (s < se)
PUT (*s++);
se += 2;
do
PUT ('0');
while (--d1 > 0);
}
while (s < se)
PUT (*s++);
if (e < 2)
PUT (s[1]);
else
{
while (++e1 <= e)
PUT ('0');
while (*s)
PUT (*s++);
}
return 0;
}
int
wrt_F (ufloat * p, int w, int d, ftnlen len)
{
int d1, sign, n;
double x;
char *b, buf[MAXINTDIGS + MAXFRACDIGS + 4], *s;
x = (len == sizeof (real) ? p->pf : p->pd);
if (d < MAXFRACDIGS)
d1 = 0;
else
{
d1 = d - MAXFRACDIGS;
d = MAXFRACDIGS;
}
if (x < 0.)
{
x = -x;
sign = 1;
}
else
{
sign = 0;
#ifndef VAX
if (!x)
x = 0.;
#endif
}
if ((n = f__scale))
{
if (n > 0)
do
x *= 10.;
while (--n > 0);
else
do
x *= 0.1;
while (++n < 0);
}
#ifdef USE_STRLEN
sprintf (b = buf, "%#.*f", d, x);
n = strlen (b) + d1;
#else
n = sprintf (b = buf, "%#.*f", d, x) + d1;
#endif
#ifndef WANT_LEAD_0
if (buf[0] == '0' && d)
{
++b;
--n;
}
#endif
if (sign)
{
/* check for all zeros */
for (s = b;;)
{
while (*s == '0')
s++;
switch (*s)
{
case '.':
s++;
continue;
case 0:
sign = 0;
}
break;
}
}
if (sign || f__cplus)
++n;
if (n > w)
{
#ifdef WANT_LEAD_0
if (buf[0] == '0' && --n == w)
++b;
else
#endif
{
while (--w >= 0)
PUT ('*');
return 0;
}
}
for (w -= n; --w >= 0;)
PUT (' ');
if (sign)
PUT ('-');
else if (f__cplus)
PUT ('+');
while ((n = *b++))
PUT (n);
while (--d1 >= 0)
PUT ('0');
return 0;
}