freebsd-skq/contrib/libf2c/libI77/wrtfmt.c
2004-07-28 03:12:14 +00:00

408 lines
7.8 KiB
C

#include "config.h"
#include "f2c.h"
#include "fio.h"
#include "fmt.h"
extern icilist *f__svic;
extern char *f__icptr;
static int
mv_cur (void) /* shouldn't use fseek because it insists on calling fflush */
/* instead we know too much about stdio */
{
int cursor = f__cursor;
f__cursor = 0;
if (f__external == 0)
{
if (cursor < 0)
{
if (f__hiwater < f__recpos)
f__hiwater = f__recpos;
f__recpos += cursor;
f__icptr += cursor;
if (f__recpos < 0)
err (f__elist->cierr, 110, "left off");
}
else if (cursor > 0)
{
if (f__recpos + cursor >= f__svic->icirlen)
err (f__elist->cierr, 110, "recend");
if (f__hiwater <= f__recpos)
for (; cursor > 0; cursor--)
(*f__putn) (' ');
else if (f__hiwater <= f__recpos + cursor)
{
cursor -= f__hiwater - f__recpos;
f__icptr += f__hiwater - f__recpos;
f__recpos = f__hiwater;
for (; cursor > 0; cursor--)
(*f__putn) (' ');
}
else
{
f__icptr += cursor;
f__recpos += cursor;
}
}
return (0);
}
if (cursor > 0)
{
if (f__hiwater <= f__recpos)
for (; cursor > 0; cursor--)
(*f__putn) (' ');
else if (f__hiwater <= f__recpos + cursor)
{
cursor -= f__hiwater - f__recpos;
f__recpos = f__hiwater;
for (; cursor > 0; cursor--)
(*f__putn) (' ');
}
else
{
f__recpos += cursor;
}
}
else if (cursor < 0)
{
if (cursor + f__recpos < 0)
err (f__elist->cierr, 110, "left off");
if (f__hiwater < f__recpos)
f__hiwater = f__recpos;
f__recpos += cursor;
}
return (0);
}
static int
wrt_Z (Uint * n, int w, int minlen, ftnlen len)
{
register char *s, *se;
register int i, w1;
static int one = 1;
static char hex[] = "0123456789ABCDEF";
s = (char *) n;
--len;
if (*(char *) &one)
{
/* little endian */
se = s;
s += len;
i = -1;
}
else
{
se = s + len;
i = 1;
}
for (;; s += i)
if (s == se || *s)
break;
w1 = (i * (se - s) << 1) + 1;
if (*s & 0xf0)
w1++;
if (w1 > w)
for (i = 0; i < w; i++)
(*f__putn) ('*');
else
{
if ((minlen -= w1) > 0)
w1 += minlen;
while (--w >= w1)
(*f__putn) (' ');
while (--minlen >= 0)
(*f__putn) ('0');
if (!(*s & 0xf0))
{
(*f__putn) (hex[*s & 0xf]);
if (s == se)
return 0;
s += i;
}
for (;; s += i)
{
(*f__putn) (hex[*s >> 4 & 0xf]);
(*f__putn) (hex[*s & 0xf]);
if (s == se)
break;
}
}
return 0;
}
static int
wrt_I (Uint * n, int w, ftnlen len, register int base)
{
int ndigit, sign, spare, i;
longint x;
char *ans;
if (len == sizeof (integer))
x = n->il;
else if (len == sizeof (char))
x = n->ic;
#ifdef Allow_TYQUAD
else if (len == sizeof (longint))
x = n->ili;
#endif
else
x = n->is;
ans = f__icvt (x, &ndigit, &sign, base);
spare = w - ndigit;
if (sign || f__cplus)
spare--;
if (spare < 0)
for (i = 0; i < w; i++)
(*f__putn) ('*');
else
{
for (i = 0; i < spare; i++)
(*f__putn) (' ');
if (sign)
(*f__putn) ('-');
else if (f__cplus)
(*f__putn) ('+');
for (i = 0; i < ndigit; i++)
(*f__putn) (*ans++);
}
return (0);
}
static int
wrt_IM (Uint * n, int w, int m, ftnlen len, int base)
{
int ndigit, sign, spare, i, xsign;
longint x;
char *ans;
if (sizeof (integer) == len)
x = n->il;
else if (len == sizeof (char))
x = n->ic;
#ifdef Allow_TYQUAD
else if (len == sizeof (longint))
x = n->ili;
#endif
else
x = n->is;
ans = f__icvt (x, &ndigit, &sign, base);
if (sign || f__cplus)
xsign = 1;
else
xsign = 0;
if (ndigit + xsign > w || m + xsign > w)
{
for (i = 0; i < w; i++)
(*f__putn) ('*');
return (0);
}
if (x == 0 && m == 0)
{
for (i = 0; i < w; i++)
(*f__putn) (' ');
return (0);
}
if (ndigit >= m)
spare = w - ndigit - xsign;
else
spare = w - m - xsign;
for (i = 0; i < spare; i++)
(*f__putn) (' ');
if (sign)
(*f__putn) ('-');
else if (f__cplus)
(*f__putn) ('+');
for (i = 0; i < m - ndigit; i++)
(*f__putn) ('0');
for (i = 0; i < ndigit; i++)
(*f__putn) (*ans++);
return (0);
}
static int
wrt_AP (char *s)
{
char quote;
int i;
if (f__cursor && (i = mv_cur ()))
return i;
quote = *s++;
for (; *s; s++)
{
if (*s != quote)
(*f__putn) (*s);
else if (*++s == quote)
(*f__putn) (*s);
else
return (1);
}
return (1);
}
static int
wrt_H (int a, char *s)
{
int i;
if (f__cursor && (i = mv_cur ()))
return i;
while (a--)
(*f__putn) (*s++);
return (1);
}
int
wrt_L (Uint * n, int len, ftnlen sz)
{
int i;
longint x;
#ifdef Allow_TYQUAD
if (sizeof (longint) == sz)
x = n->ili;
else
#endif
if (sizeof (short ) == sz)
x = n->is;
else if (sizeof (char) == sz)
x = n->ic;
else if (sizeof (integer) == sz)
x = n->il;
for (i = 0; i < len - 1; i++)
(*f__putn) (' ');
if (x)
(*f__putn) ('T');
else
(*f__putn) ('F');
return (0);
}
static int
wrt_A (char *p, ftnlen len)
{
while (len-- > 0)
(*f__putn) (*p++);
return (0);
}
static int
wrt_AW (char *p, int w, ftnlen len)
{
while (w > len)
{
w--;
(*f__putn) (' ');
}
while (w-- > 0)
(*f__putn) (*p++);
return (0);
}
static int
wrt_G (ufloat * p, int w, int d, int e, ftnlen len)
{
double up = 1, x;
int i = 0, oldscale, n, j;
x = len == sizeof (real) ? p->pf : p->pd;
if (x < 0)
x = -x;
if (x < .1)
{
if (x != 0.)
return (wrt_E (p, w, d, e, len));
i = 1;
goto have_i;
}
for (; i <= d; i++, up *= 10)
{
if (x >= up)
continue;
have_i:
oldscale = f__scale;
f__scale = 0;
if (e == 0)
n = 4;
else
n = e + 2;
i = wrt_F (p, w - n, d - i, len);
for (j = 0; j < n; j++)
(*f__putn) (' ');
f__scale = oldscale;
return (i);
}
return (wrt_E (p, w, d, e, len));
}
int
w_ed (struct syl * p, char *ptr, ftnlen len)
{
int i;
if (f__cursor && (i = mv_cur ()))
return i;
switch (p->op)
{
default:
fprintf (stderr, "w_ed, unexpected code: %d\n", p->op);
sig_die (f__fmtbuf, 1);
case I:
return (wrt_I ((Uint *) ptr, p->p1, len, 10));
case IM:
return (wrt_IM ((Uint *) ptr, p->p1, p->p2.i[0], len, 10));
/* O and OM don't work right for character, double, complex, */
/* or doublecomplex, and they differ from Fortran 90 in */
/* showing a minus sign for negative values. */
case O:
return (wrt_I ((Uint *) ptr, p->p1, len, 8));
case OM:
return (wrt_IM ((Uint *) ptr, p->p1, p->p2.i[0], len, 8));
case L:
return (wrt_L ((Uint *) ptr, p->p1, len));
case A:
return (wrt_A (ptr, len));
case AW:
return (wrt_AW (ptr, p->p1, len));
case D:
case E:
case EE:
return (wrt_E ((ufloat *) ptr, p->p1, p->p2.i[0], p->p2.i[1], len));
case G:
case GE:
return (wrt_G ((ufloat *) ptr, p->p1, p->p2.i[0], p->p2.i[1], len));
case F:
return (wrt_F ((ufloat *) ptr, p->p1, p->p2.i[0], len));
/* Z and ZM assume 8-bit bytes. */
case Z:
return (wrt_Z ((Uint *) ptr, p->p1, 0, len));
case ZM:
return (wrt_Z ((Uint *) ptr, p->p1, p->p2.i[0], len));
}
}
int
w_ned (struct syl * p)
{
switch (p->op)
{
default:
fprintf (stderr, "w_ned, unexpected code: %d\n", p->op);
sig_die (f__fmtbuf, 1);
case SLASH:
return ((*f__donewrec) ());
case T:
f__cursor = p->p1 - f__recpos - 1;
return (1);
case TL:
f__cursor -= p->p1;
if (f__cursor < -f__recpos) /* TL1000, 1X */
f__cursor = -f__recpos;
return (1);
case TR:
case X:
f__cursor += p->p1;
return (1);
case APOS:
return (wrt_AP (p->p2.s));
case H:
return (wrt_H (p->p1, p->p2.s));
}
}