mirror of
git://gcc.gnu.org/git/gcc.git
synced 2024-12-21 08:03:41 +08:00
5cad287eff
* libI77/backspace.c: Include "config.h". * libI77/close.c: Likewise. * libI77/dfe.c: Likewise. * libI77/dolio.c: Likewise. * libI77/due.c: Likewise. * libI77/err.c: Likewise. * libI77/fmt.c: Likewise. * libI77/fmtlib.c: Likewise. * libI77/ftell_.c: Likewise. * libI77/ilnw.c: Likewise. * libI77/lread.c: Likewise. * libI77/open.c: Likewise. * libI77/rdfmt.c: Likewise. * libI77/rsfe.c: Likewise. * libI77/rsne.c: Likewise. * libI77/util.c: Likewise. * libI77/wrtfmt.c: Likewise. * libI77/wsne.c: Likewise. * libI77/xwsne.c: Likewise. * libI77/config.h.in: Generate with autoheader. * libI77/configure.in: Add comments for all AC_DEFINES so that autoheader can grok it. * libI77/configure: Regenerated. From-SVN: r42162
367 lines
7.3 KiB
C
367 lines
7.3 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
|
|
#ifdef KR_headers
|
|
wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len;
|
|
#else
|
|
wrt_Z(Uint *n, int w, int minlen, ftnlen len)
|
|
#endif
|
|
{
|
|
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
|
|
#ifdef KR_headers
|
|
wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base;
|
|
#else
|
|
wrt_I(Uint *n, int w, ftnlen len, register int base)
|
|
#endif
|
|
{ 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
|
|
#ifdef KR_headers
|
|
wrt_IM(n,w,m,len,base) Uint *n; ftnlen len; int base;
|
|
#else
|
|
wrt_IM(Uint *n, int w, int m, ftnlen len, int base)
|
|
#endif
|
|
{ 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
|
|
#ifdef KR_headers
|
|
wrt_AP(s) char *s;
|
|
#else
|
|
wrt_AP(char *s)
|
|
#endif
|
|
{ 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
|
|
#ifdef KR_headers
|
|
wrt_H(a,s) char *s;
|
|
#else
|
|
wrt_H(int a, char *s)
|
|
#endif
|
|
{
|
|
int i;
|
|
|
|
if(f__cursor && (i = mv_cur()))
|
|
return i;
|
|
while(a--) (*f__putn)(*s++);
|
|
return(1);
|
|
}
|
|
#ifdef KR_headers
|
|
wrt_L(n,len, sz) Uint *n; ftnlen sz;
|
|
#else
|
|
wrt_L(Uint *n, int len, ftnlen sz)
|
|
#endif
|
|
{ int i;
|
|
long x;
|
|
if(sizeof(long)==sz) x=n->il;
|
|
else if(sz == sizeof(char)) x = n->ic;
|
|
else x=n->is;
|
|
for(i=0;i<len-1;i++)
|
|
(*f__putn)(' ');
|
|
if(x) (*f__putn)('T');
|
|
else (*f__putn)('F');
|
|
return(0);
|
|
}
|
|
static int
|
|
#ifdef KR_headers
|
|
wrt_A(p,len) char *p; ftnlen len;
|
|
#else
|
|
wrt_A(char *p, ftnlen len)
|
|
#endif
|
|
{
|
|
while(len-- > 0) (*f__putn)(*p++);
|
|
return(0);
|
|
}
|
|
static int
|
|
#ifdef KR_headers
|
|
wrt_AW(p,w,len) char * p; ftnlen len;
|
|
#else
|
|
wrt_AW(char * p, int w, ftnlen len)
|
|
#endif
|
|
{
|
|
while(w>len)
|
|
{ w--;
|
|
(*f__putn)(' ');
|
|
}
|
|
while(w-- > 0)
|
|
(*f__putn)(*p++);
|
|
return(0);
|
|
}
|
|
|
|
static int
|
|
#ifdef KR_headers
|
|
wrt_G(p,w,d,e,len) ufloat *p; ftnlen len;
|
|
#else
|
|
wrt_G(ufloat *p, int w, int d, int e, ftnlen len)
|
|
#endif
|
|
{ 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));
|
|
}
|
|
#ifdef KR_headers
|
|
w_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
|
|
#else
|
|
w_ed(struct syl *p, char *ptr, ftnlen len)
|
|
#endif
|
|
{
|
|
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));
|
|
}
|
|
}
|
|
#ifdef KR_headers
|
|
w_ned(p) struct syl *p;
|
|
#else
|
|
w_ned(struct syl *p)
|
|
#endif
|
|
{
|
|
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));
|
|
}
|
|
}
|