freebsd-dev/contrib/libf2c/libI77/lwrite.c
2003-07-11 03:42:19 +00:00

278 lines
4.1 KiB
C

#include "f2c.h"
#include "fio.h"
#include "fmt.h"
#include "lio.h"
ftnint L_len;
int f__Aquote;
static void
donewrec (void)
{
if (f__recpos)
(*f__donewrec) ();
}
static void
lwrt_I (longint n)
{
char *p;
int ndigit, sign;
p = f__icvt (n, &ndigit, &sign, 10);
if (f__recpos + ndigit >= L_len)
donewrec ();
PUT (' ');
if (sign)
PUT ('-');
while (*p)
PUT (*p++);
}
static void
lwrt_L (ftnint n, ftnlen len)
{
if (f__recpos + LLOGW >= L_len)
donewrec ();
wrt_L ((Uint *) & n, LLOGW, len);
}
static void
lwrt_A (char *p, ftnlen len)
{
int a;
char *p1, *pe;
a = 0;
pe = p + len;
if (f__Aquote)
{
a = 3;
if (len > 1 && p[len - 1] == ' ')
{
while (--len > 1 && p[len - 1] == ' ');
pe = p + len;
}
p1 = p;
while (p1 < pe)
if (*p1++ == '\'')
a++;
}
if (f__recpos + len + a >= L_len)
donewrec ();
if (a
#ifndef OMIT_BLANK_CC
|| !f__recpos
#endif
)
PUT (' ');
if (a)
{
PUT ('\'');
while (p < pe)
{
if (*p == '\'')
PUT ('\'');
PUT (*p++);
}
PUT ('\'');
}
else
while (p < pe)
PUT (*p++);
}
static int
l_g (char *buf, double n)
{
#ifdef Old_list_output
doublereal absn;
char *fmt;
absn = n;
if (absn < 0)
absn = -absn;
fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
#ifdef USE_STRLEN
sprintf (buf, fmt, n);
return strlen (buf);
#else
return sprintf (buf, fmt, n);
#endif
#else
register char *b, c, c1;
b = buf;
*b++ = ' ';
if (n < 0)
{
*b++ = '-';
n = -n;
}
else
*b++ = ' ';
if (n == 0)
{
*b++ = '0';
*b++ = '.';
*b = 0;
goto f__ret;
}
sprintf (b, LGFMT, n);
switch (*b)
{
#ifndef WANT_LEAD_0
case '0':
while (b[0] = b[1])
b++;
break;
#endif
case 'i':
case 'I':
/* Infinity */
case 'n':
case 'N':
/* NaN */
while (*++b);
break;
default:
/* Fortran 77 insists on having a decimal point... */
for (;; b++)
switch (*b)
{
case 0:
*b++ = '.';
*b = 0;
goto f__ret;
case '.':
while (*++b);
goto f__ret;
case 'E':
for (c1 = '.', c = 'E'; (*b = c1); c1 = c, c = *++b);
goto f__ret;
}
}
f__ret:
return b - buf;
#endif
}
static void
l_put (register char *s)
{
register void (*pn) (int) = f__putn;
register int c;
while ((c = *s++))
(*pn) (c);
}
static void
lwrt_F (double n)
{
char buf[LEFBL];
if (f__recpos + l_g (buf, n) >= L_len)
donewrec ();
l_put (buf);
}
static void
lwrt_C (double a, double b)
{
char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
int al, bl;
al = l_g (bufa, a);
for (ba = bufa; *ba == ' '; ba++)
--al;
bl = l_g (bufb, b) + 1; /* intentionally high by 1 */
for (bb = bufb; *bb == ' '; bb++)
--bl;
if (f__recpos + al + bl + 3 >= L_len)
donewrec ();
#ifdef OMIT_BLANK_CC
else
#endif
PUT (' ');
PUT ('(');
l_put (ba);
PUT (',');
if (f__recpos + bl >= L_len)
{
(*f__donewrec) ();
#ifndef OMIT_BLANK_CC
PUT (' ');
#endif
}
l_put (bb);
PUT (')');
}
int
l_write (ftnint * number, char *ptr, ftnlen len, ftnint type)
{
#define Ptr ((flex *)ptr)
int i;
longint x;
double y, z;
real *xx;
doublereal *yy;
for (i = 0; i < *number; i++)
{
switch ((int) type)
{
default:
f__fatal (204, "unknown type in lio");
case TYINT1:
x = Ptr->flchar;
goto xint;
case TYSHORT:
x = Ptr->flshort;
goto xint;
#ifdef Allow_TYQUAD
case TYQUAD:
x = Ptr->fllongint;
goto xint;
#endif
case TYLONG:
x = Ptr->flint;
xint:lwrt_I (x);
break;
case TYREAL:
y = Ptr->flreal;
goto xfloat;
case TYDREAL:
y = Ptr->fldouble;
xfloat:lwrt_F (y);
break;
case TYCOMPLEX:
xx = &Ptr->flreal;
y = *xx++;
z = *xx;
goto xcomplex;
case TYDCOMPLEX:
yy = &Ptr->fldouble;
y = *yy++;
z = *yy;
xcomplex:
lwrt_C (y, z);
break;
case TYLOGICAL1:
x = Ptr->flchar;
goto xlog;
case TYLOGICAL2:
x = Ptr->flshort;
goto xlog;
case TYLOGICAL:
x = Ptr->flint;
xlog:lwrt_L (Ptr->flint, len);
break;
case TYCHAR:
lwrt_A (ptr, len);
break;
}
ptr += len;
}
return (0);
}