freebsd-dev/contrib/libf2c/libI77/rdfmt.c
2002-05-09 22:47:59 +00:00

547 lines
8.7 KiB
C

#include "config.h"
#include <ctype.h>
#include "f2c.h"
#include "fio.h"
extern int f__cursor;
#ifdef KR_headers
extern double atof();
#else
#undef abs
#undef min
#undef max
#include <stdlib.h>
#endif
#include "fmt.h"
#include "fp.h"
static int
#ifdef KR_headers
rd_Z(n,w,len) Uint *n; ftnlen len;
#else
rd_Z(Uint *n, int w, ftnlen len)
#endif
{
long x[9];
char *s, *s0, *s1, *se, *t;
int ch, i, w1, w2;
static char hex[256];
static int one = 1;
int bad = 0;
if (!hex['0']) {
s = "0123456789";
while(ch = *s++)
hex[ch] = ch - '0' + 1;
s = "ABCDEF";
while(ch = *s++)
hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11;
}
s = s0 = (char *)x;
s1 = (char *)&x[4];
se = (char *)&x[8];
if (len > 4*sizeof(long))
return errno = 117;
while (w) {
GET(ch);
if (ch==',' || ch=='\n')
break;
w--;
if (ch > ' ') {
if (!hex[ch & 0xff])
bad++;
*s++ = ch;
if (s == se) {
/* discard excess characters */
for(t = s0, s = s1; t < s1;)
*t++ = *s++;
s = s1;
}
}
}
if (bad)
return errno = 115;
w = (int)len;
w1 = s - s0;
w2 = w1+1 >> 1;
t = (char *)n;
if (*(char *)&one) {
/* little endian */
t += w - 1;
i = -1;
}
else
i = 1;
for(; w > w2; t += i, --w)
*t = 0;
if (!w)
return 0;
if (w < w2)
s0 = s - (w << 1);
else if (w1 & 1) {
*t = hex[*s0++ & 0xff] - 1;
if (!--w)
return 0;
t += i;
}
do {
*t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1;
t += i;
s0 += 2;
}
while(--w);
return 0;
}
static int
#ifdef KR_headers
rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base;
#else
rd_I(Uint *n, int w, ftnlen len, register int base)
#endif
{
int bad, ch, sign;
longint x = 0;
if (w <= 0)
goto have_x;
for(;;) {
GET(ch);
if (ch != ' ')
break;
if (!--w)
goto have_x;
}
sign = 0;
switch(ch) {
case ',':
case '\n':
w = 0;
goto have_x;
case '-':
sign = 1;
case '+':
break;
default:
if (ch >= '0' && ch <= '9') {
x = ch - '0';
break;
}
goto have_x;
}
while(--w) {
GET(ch);
if (ch >= '0' && ch <= '9') {
x = x*base + ch - '0';
continue;
}
if (ch != ' ') {
if (ch == '\n' || ch == ',')
w = 0;
break;
}
if (f__cblank)
x *= base;
}
if (sign)
x = -x;
have_x:
if(len == sizeof(integer))
n->il=x;
else if(len == sizeof(char))
n->ic = (char)x;
#ifdef Allow_TYQUAD
else if (len == sizeof(longint))
n->ili = x;
#endif
else
n->is = (short)x;
if (w) {
while(--w)
GET(ch);
return errno = 115;
}
return 0;
}
static int
#ifdef KR_headers
rd_L(n,w,len) ftnint *n; ftnlen len;
#else
rd_L(ftnint *n, int w, ftnlen len)
#endif
{ int ch, dot, lv;
if (w <= 0)
goto bad;
for(;;) {
GET(ch);
--w;
if (ch != ' ')
break;
if (!w)
goto bad;
}
dot = 0;
retry:
switch(ch) {
case '.':
if (dot++ || !w)
goto bad;
GET(ch);
--w;
goto retry;
case 't':
case 'T':
lv = 1;
break;
case 'f':
case 'F':
lv = 0;
break;
default:
bad:
for(; w > 0; --w)
GET(ch);
/* no break */
case ',':
case '\n':
return errno = 116;
}
/* The switch statement that was here
didn't cut it: It broke down for targets
where sizeof(char) == sizeof(short). */
if (len == sizeof(char))
*(char *)n = (char)lv;
else if (len == sizeof(short))
*(short *)n = (short)lv;
else
*n = lv;
while(w-- > 0) {
GET(ch);
if (ch == ',' || ch == '\n')
break;
}
return 0;
}
static int
#ifdef KR_headers
rd_F(p, w, d, len) ufloat *p; ftnlen len;
#else
rd_F(ufloat *p, int w, int d, ftnlen len)
#endif
{
char s[FMAX+EXPMAXDIGS+4];
register int ch;
register char *sp, *spe, *sp1;
double x;
int scale1, se;
long e, exp;
sp1 = sp = s;
spe = sp + FMAX;
exp = -d;
x = 0.;
do {
GET(ch);
w--;
} while (ch == ' ' && w);
switch(ch) {
case '-': *sp++ = ch; sp1++; spe++;
case '+':
if (!w) goto zero;
--w;
GET(ch);
}
while(ch == ' ') {
blankdrop:
if (!w--) goto zero; GET(ch); }
while(ch == '0')
{ if (!w--) goto zero; GET(ch); }
if (ch == ' ' && f__cblank)
goto blankdrop;
scale1 = f__scale;
while(isdigit(ch)) {
digloop1:
if (sp < spe) *sp++ = ch;
else ++exp;
digloop1e:
if (!w--) goto done;
GET(ch);
}
if (ch == ' ') {
if (f__cblank)
{ ch = '0'; goto digloop1; }
goto digloop1e;
}
if (ch == '.') {
exp += d;
if (!w--) goto done;
GET(ch);
if (sp == sp1) { /* no digits yet */
while(ch == '0') {
skip01:
--exp;
skip0:
if (!w--) goto done;
GET(ch);
}
if (ch == ' ') {
if (f__cblank) goto skip01;
goto skip0;
}
}
while(isdigit(ch)) {
digloop2:
if (sp < spe)
{ *sp++ = ch; --exp; }
digloop2e:
if (!w--) goto done;
GET(ch);
}
if (ch == ' ') {
if (f__cblank)
{ ch = '0'; goto digloop2; }
goto digloop2e;
}
}
switch(ch) {
default:
break;
case '-': se = 1; goto signonly;
case '+': se = 0; goto signonly;
case 'e':
case 'E':
case 'd':
case 'D':
if (!w--)
goto bad;
GET(ch);
while(ch == ' ') {
if (!w--)
goto bad;
GET(ch);
}
se = 0;
switch(ch) {
case '-': se = 1;
case '+':
signonly:
if (!w--)
goto bad;
GET(ch);
}
while(ch == ' ') {
if (!w--)
goto bad;
GET(ch);
}
if (!isdigit(ch))
goto bad;
e = ch - '0';
for(;;) {
if (!w--)
{ ch = '\n'; break; }
GET(ch);
if (!isdigit(ch)) {
if (ch == ' ') {
if (f__cblank)
ch = '0';
else continue;
}
else
break;
}
e = 10*e + ch - '0';
if (e > EXPMAX && sp > sp1)
goto bad;
}
if (se)
exp -= e;
else
exp += e;
scale1 = 0;
}
switch(ch) {
case '\n':
case ',':
break;
default:
bad:
return (errno = 115);
}
done:
if (sp > sp1) {
while(*--sp == '0')
++exp;
if (exp -= scale1)
sprintf(sp+1, "e%ld", exp);
else
sp[1] = 0;
x = atof(s);
}
zero:
if (len == sizeof(real))
p->pf = x;
else
p->pd = x;
return(0);
}
static int
#ifdef KR_headers
rd_A(p,len) char *p; ftnlen len;
#else
rd_A(char *p, ftnlen len)
#endif
{ int i,ch;
for(i=0;i<len;i++)
{ GET(ch);
*p++=VAL(ch);
}
return(0);
}
static int
#ifdef KR_headers
rd_AW(p,w,len) char *p; ftnlen len;
#else
rd_AW(char *p, int w, ftnlen len)
#endif
{ int i,ch;
if(w>=len)
{ for(i=0;i<w-len;i++)
GET(ch);
for(i=0;i<len;i++)
{ GET(ch);
*p++=VAL(ch);
}
return(0);
}
for(i=0;i<w;i++)
{ GET(ch);
*p++=VAL(ch);
}
for(i=0;i<len-w;i++) *p++=' ';
return(0);
}
static int
#ifdef KR_headers
rd_H(n,s) char *s;
#else
rd_H(int n, char *s)
#endif
{ int i,ch;
for(i=0;i<n;i++)
if((ch=(*f__getn)())<0) return(ch);
else *s++ = ch=='\n'?' ':ch;
return(1);
}
static int
#ifdef KR_headers
rd_POS(s) char *s;
#else
rd_POS(char *s)
#endif
{ char quote;
int ch;
quote= *s++;
for(;*s;s++)
if(*s==quote && *(s+1)!=quote) break;
else if((ch=(*f__getn)())<0) return(ch);
else *s = ch=='\n'?' ':ch;
return(1);
}
#ifdef KR_headers
rd_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
#else
rd_ed(struct syl *p, char *ptr, ftnlen len)
#endif
{ int ch;
for(;f__cursor>0;f__cursor--) if((ch=(*f__getn)())<0) return(ch);
if(f__cursor<0)
{ if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/
f__cursor = -f__recpos; /* is this in the standard? */
if(f__external == 0) {
extern char *f__icptr;
f__icptr += f__cursor;
}
else if(f__curunit && f__curunit->useek)
FSEEK(f__cf,(off_t)f__cursor,SEEK_CUR);
else
err(f__elist->cierr,106,"fmt");
f__recpos += f__cursor;
f__cursor=0;
}
switch(p->op)
{
default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op);
sig_die(f__fmtbuf, 1);
case IM:
case I: ch = rd_I((Uint *)ptr,p->p1,len, 10);
break;
/* 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 OM:
case O: ch = rd_I((Uint *)ptr, p->p1, len, 8);
break;
case L: ch = rd_L((ftnint *)ptr,p->p1,len);
break;
case A: ch = rd_A(ptr,len);
break;
case AW:
ch = rd_AW(ptr,p->p1,len);
break;
case E: case EE:
case D:
case G:
case GE:
case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2.i[0],len);
break;
/* Z and ZM assume 8-bit bytes. */
case ZM:
case Z:
ch = rd_Z((Uint *)ptr, p->p1, len);
break;
}
if(ch == 0) return(ch);
else if(ch == EOF) return(EOF);
if (f__cf)
clearerr(f__cf);
return(errno);
}
#ifdef KR_headers
rd_ned(p) struct syl *p;
#else
rd_ned(struct syl *p)
#endif
{
switch(p->op)
{
default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op);
sig_die(f__fmtbuf, 1);
case APOS:
return(rd_POS(p->p2.s));
case H: return(rd_H(p->p1,p->p2.s));
case SLASH: return((*f__donewrec)());
case TR:
case X: f__cursor += p->p1;
return(1);
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);
}
}