38d2602fc1
the function naming problem for complex double function i've recently aksed for in -committers. (The recently committed rev 1.5 of proc.c was actually also part of this update.) Should the mailing lists come to an agreement that f2c better belongs into the ports, this could be done nevertheless. For the time being, we've at least got a current version now. Thanks, Steve! Submitted by: Steve Kargl <sgk@troutmask.apl.washington.edu>
477 lines
8.1 KiB
C
477 lines
8.1 KiB
C
#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"
|
|
#include "ctype.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
|
|
{ longint x;
|
|
int sign,ch;
|
|
char s[84], *ps;
|
|
ps=s; x=0;
|
|
while (w)
|
|
{
|
|
GET(ch);
|
|
if (ch==',' || ch=='\n') break;
|
|
*ps=ch; ps++; w--;
|
|
}
|
|
*ps='\0';
|
|
ps=s;
|
|
while (*ps==' ') ps++;
|
|
if (*ps=='-') { sign=1; ps++; }
|
|
else { sign=0; if (*ps=='+') ps++; }
|
|
loop: while (*ps>='0' && *ps<='9') { x=x*base+(*ps-'0'); ps++; }
|
|
if (*ps==' ') {if (f__cblank) x *= base; ps++; goto loop;}
|
|
if(sign) x = -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 (*ps) return(errno=115); else 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, lv;
|
|
char s[84], *ps;
|
|
ps=s;
|
|
while (w) {
|
|
GET(ch);
|
|
if (ch==','||ch=='\n') break;
|
|
*ps=ch;
|
|
ps++; w--;
|
|
}
|
|
*ps='\0';
|
|
ps=s; while (*ps==' ') ps++;
|
|
if (*ps=='.') ps++;
|
|
if (*ps=='t' || *ps == 'T')
|
|
lv = 1;
|
|
else if (*ps == 'f' || *ps == 'F')
|
|
lv = 0;
|
|
else return(errno=116);
|
|
switch(len) {
|
|
case sizeof(char): *(char *)n = (char)lv; break;
|
|
case sizeof(short): *(short *)n = (short)lv; break;
|
|
default: *n = lv;
|
|
}
|
|
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)
|
|
(void) fseek(f__cf,(long) 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);
|
|
}
|
|
}
|