xref: /csrg-svn/usr.bin/f77/libI77/wrtfmt.c (revision 19985)
12504Sdlw /*
2*19985Slibs char id_wrtfmt[] = "@(#)wrtfmt.c	1.10";
32504Sdlw  *
42504Sdlw  * formatted write routines
52504Sdlw  */
62504Sdlw 
72504Sdlw #include "fio.h"
82603Sdlw #include "format.h"
92504Sdlw 
102504Sdlw extern char *icvt();
1117969Slibs extern char *s_init;
122504Sdlw 
132504Sdlw #define abs(x) (x<0?-x:x)
142504Sdlw 
152504Sdlw w_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len;
162504Sdlw {	int n;
172504Sdlw 	if(cursor && (n=wr_mvcur())) return(n);
182504Sdlw 	switch(p->op)
192504Sdlw 	{
202504Sdlw 	case I:
212504Sdlw 	case IM:
222504Sdlw 		return(wrt_IM(ptr,p->p1,p->p2,len));
232504Sdlw 	case L:
24*19985Slibs 		return(wrt_L(ptr,p->p1,len));
252504Sdlw 	case A:
2617969Slibs 		return(wrt_AW(ptr,len,len));
272504Sdlw 	case AW:
282504Sdlw 		return(wrt_AW(ptr,p->p1,len));
292504Sdlw 	case D:
3017969Slibs 		return(wrt_E(ptr,p->p1,p->p2,2,len,'d'));
312504Sdlw 	case DE:
3217969Slibs 		return(wrt_E(ptr,p->p1,(p->p2)&0xff,((p->p2)>>8)&0xff,len,'d'));
332504Sdlw 	case E:
3417969Slibs 		return(wrt_E(ptr,p->p1,p->p2,2,len,'e'));
352504Sdlw 	case EE:
3617969Slibs 		return(wrt_E(ptr,p->p1,(p->p2)&0xff,((p->p2)>>8)&0xff,len,'e'));
372504Sdlw 	case G:
3817969Slibs 		return(wrt_G(ptr,p->p1,p->p2,2,len));
392504Sdlw 	case GE:
4017969Slibs 		return(wrt_G(ptr,p->p1,(p->p2)&0xff,((p->p2)>>8)&0xff,len));
412504Sdlw 	case F:
422504Sdlw 		return(wrt_F(ptr,p->p1,p->p2,len));
432504Sdlw 	default:
442603Sdlw 		return(errno=F_ERFMT);
452504Sdlw 	}
462504Sdlw }
472504Sdlw 
482504Sdlw w_ned(p,ptr) char *ptr; struct syl *p;
492504Sdlw {
502504Sdlw 	switch(p->op)
512504Sdlw 	{
522504Sdlw 	case SLASH:
532504Sdlw 		return((*donewrec)());
542504Sdlw 	case T:
552504Sdlw 		if(p->p1) cursor = p->p1 - recpos - 1;
562504Sdlw #ifndef KOSHER
572504Sdlw 		else cursor = 8*p->p2 - recpos%8;	/* NOT STANDARD FORT */
582504Sdlw #endif
592504Sdlw 		tab = YES;
602504Sdlw 		return(OK);
612504Sdlw 	case TL:
622504Sdlw 		cursor -= p->p1;
6312371Sdlw 		if ((recpos + cursor) < 0) cursor = -recpos;	/* ANSI req'd */
642504Sdlw 		tab = YES;
652504Sdlw 		return(OK);
662504Sdlw 	case TR:
672504Sdlw 	case X:
682504Sdlw 		cursor += p->p1;
6912371Sdlw 		/* tab = (p->op == TR); this would implement destructive X */
7012371Sdlw 		tab = YES;
712504Sdlw 		return(OK);
722504Sdlw 	case APOS:
7317969Slibs 		return(wrt_AP(&s_init[p->p1]));
742504Sdlw 	case H:
7517969Slibs 		return(wrt_H(p->p1,&s_init[p->p2]));
762504Sdlw 	default:
772603Sdlw 		return(errno=F_ERFMT);
782504Sdlw 	}
792504Sdlw }
802504Sdlw 
812504Sdlw wr_mvcur()
822504Sdlw {	int n;
832504Sdlw 	if(tab) return((*dotab)());
8412466Sdlw 	if (cursor < 0) return(errno=F_ERSEEK);
852504Sdlw 	while(cursor--) PUT(' ')
862504Sdlw 	return(cursor=0);
872504Sdlw }
882504Sdlw 
892504Sdlw wrt_IM(ui,w,m,len) uint *ui; ftnlen len;
902504Sdlw {	int ndigit,sign,spare,i,xsign,n;
912504Sdlw 	long x;
922504Sdlw 	char *ans;
932504Sdlw 	if(sizeof(short)==len) x=ui->is;
942504Sdlw /*	else if(len == sizeof(char)) x = ui->ic; */
952504Sdlw 	else x=ui->il;
962504Sdlw 	if(x==0 && m==0)
972504Sdlw 	{	for(i=0;i<w;i++) PUT(' ')
982504Sdlw 		return(OK);
992504Sdlw 	}
1002504Sdlw 	ans=icvt(x,&ndigit,&sign);
1012504Sdlw 	if(sign || cplus) xsign=1;
1022504Sdlw 	else xsign=0;
1032504Sdlw 	if(ndigit+xsign>w || m+xsign>w)
1042504Sdlw 	{	for(i=0;i<w;i++) PUT('*')
1052504Sdlw 		return(OK);
1062504Sdlw 	}
1072504Sdlw 	if(ndigit>=m)
1082504Sdlw 		spare=w-ndigit-xsign;
1092504Sdlw 	else
1102504Sdlw 		spare=w-m-xsign;
1112504Sdlw 	for(i=0;i<spare;i++) PUT(' ')
1122504Sdlw 	if(sign) PUT('-')
1132504Sdlw 	else if(cplus) PUT('+')
1142504Sdlw 	for(i=0;i<m-ndigit;i++) PUT('0')
1152504Sdlw 	for(i=0;i<ndigit;i++) PUT(*ans++)
1162504Sdlw 	return(OK);
1172504Sdlw }
1182504Sdlw 
1192504Sdlw wrt_AP(p)
1202504Sdlw {	char *s,quote;
1212504Sdlw 	int n;
1222504Sdlw 	if(cursor && (n=wr_mvcur())) return(n);
1232504Sdlw 	s=(char *)p;
1242504Sdlw 	quote = *s++;
1252504Sdlw 	for(; *s; s++)
1262504Sdlw 	{	if(*s!=quote) PUT(*s)
1272504Sdlw 		else if(*++s==quote) PUT(*s)
1282504Sdlw 		else return(OK);
1292504Sdlw 	}
1302504Sdlw 	return(OK);
1312504Sdlw }
1322504Sdlw 
1332504Sdlw wrt_H(a,b)
1342504Sdlw {	char *s=(char *)b;
1352504Sdlw 	int n;
1362504Sdlw 	if(cursor && (n=wr_mvcur())) return(n);
1372504Sdlw 	while(a--) PUT(*s++)
1382504Sdlw 	return(OK);
1392504Sdlw }
1402504Sdlw 
141*19985Slibs wrt_L(l,width,len) uint *l; ftnlen len;
1422504Sdlw {	int i,n;
143*19985Slibs 	for(i=0;i<width-1;i++) PUT(' ')
144*19985Slibs 	if(len == sizeof (short))
145*19985Slibs 		i = l->is;
146*19985Slibs 	else
147*19985Slibs 		i = l->il;
148*19985Slibs 	if(i) PUT('t')
1492504Sdlw 	else PUT('f')
1502504Sdlw 	return(OK);
1512504Sdlw }
1522504Sdlw 
1532504Sdlw wrt_AW(p,w,len) char * p; ftnlen len;
1542504Sdlw {	int n;
1552504Sdlw 	while(w>len)
1562504Sdlw 	{	w--;
1572504Sdlw 		PUT(' ')
1582504Sdlw 	}
1592504Sdlw 	while(w-- > 0)
1602504Sdlw 		PUT(*p++)
1612504Sdlw 	return(OK);
1622504Sdlw }
1632504Sdlw 
16412039Sdlw wrt_E(p,w,d,e,len,expch) ufloat *p; ftnlen len; char expch;
16512039Sdlw {	char *s,ex[4];
1662504Sdlw 	int dd,dp,sign,i,delta,pad,n;
1672504Sdlw 	char *ecvt();
16812039Sdlw 
1692504Sdlw 	if((len==sizeof(float)?p->pf:p->pd)==0.0)
1702504Sdlw 	{
17117229Sdlw 		n = cblank;
17217229Sdlw 		cblank = 1;	/* force '0' fill */
1732504Sdlw 		wrt_F(p,w-(e+2),d,len);
17417229Sdlw 		cblank = n;
1752504Sdlw 		PUT(expch)
1762504Sdlw 		PUT('+')
1772504Sdlw /*		for(i=0;i<(e-1);i++)PUT(' ')
1782504Sdlw deleted		PUT('0')
1792504Sdlw  */
1802504Sdlw /* added */	for(i=0;i<e;i++) PUT('0')
1812504Sdlw 		return(OK);
1822504Sdlw 	}
18312371Sdlw 	if (scale > 0) {	/* insane ANSI requirement */
18412371Sdlw 		dd = d + 1;
18512371Sdlw 		d = dd - scale;
18612371Sdlw 	} else
18712371Sdlw 		dd = d + scale;
18812371Sdlw 	if (dd <= 0 || d < 0) goto E_badfield;
1892504Sdlw 	s=ecvt( (len==sizeof(float)?(double)p->pf:p->pd) ,dd,&dp,&sign);
1902504Sdlw 	delta = 3+e;
1912504Sdlw 	if(sign||cplus) delta++;
1922504Sdlw 	pad=w-(delta+d)-(scale>0? scale:0);
19312371Sdlw 	if(pad<0) {
19412371Sdlw E_badfield:
19512371Sdlw 		for(i=0;i<w;i++) PUT('*')
1962504Sdlw 		return(OK);
1972504Sdlw 	}
1982504Sdlw 	for(i=0;i<(pad-(scale<=0?1:0));i++) PUT(' ')
1992504Sdlw 	if(sign) PUT('-')
2002504Sdlw 	else if(cplus) PUT('+')
2012504Sdlw 	if(scale<=0 && pad) PUT('0')
2022504Sdlw 	if(scale<0 && scale > -d)
2032504Sdlw 	{
2042504Sdlw 		PUT('.')
2052504Sdlw 		for(i=0;i<-scale;i++)
2062504Sdlw 			PUT('0')
2072504Sdlw 		for(i=0;i<d+scale;i++)
2082504Sdlw 			PUT(*s++)
2092504Sdlw 	}
2102504Sdlw 	else
2112504Sdlw 	{
2122504Sdlw 		if(scale>0)
2132504Sdlw 			for(i=0;i<scale;i++)
2142504Sdlw 				PUT(*s++)
2152504Sdlw 		PUT('.')
2162504Sdlw 		for(i=0;i<d;i++)
2172504Sdlw 			PUT(*s++)
2182504Sdlw 	}
2192504Sdlw 	dp -= scale;
2202504Sdlw 	sprintf(ex,"%d",abs(dp));
2212504Sdlw 	if((pad=strlen(ex))>e)
2222504Sdlw 	{	if(pad>(++e))
2232504Sdlw 		{	PUT(expch)
2242504Sdlw 			for(i=0;i<e;i++) PUT('*')
2252504Sdlw 			return(OK);
2262504Sdlw 		}
2272504Sdlw 	}
2282504Sdlw 	else PUT(expch)
2292504Sdlw 	PUT(dp<0?'-':'+')
2302504Sdlw 	for(i=0;i<(e-pad);i++) PUT('0')  /* was ' ' */
2312504Sdlw 	s= &ex[0];
2322504Sdlw 	while(*s) PUT(*s++)
2332504Sdlw 	return(OK);
2342504Sdlw }
2352504Sdlw 
2362504Sdlw wrt_G(p,w,d,e,len) ufloat *p; ftnlen len;
2372504Sdlw {	double uplim = 1.0, x;
2382504Sdlw 	int i,oldscale,n,j,ne;
2392504Sdlw 	x=(len==sizeof(float)?(double)p->pf:p->pd);
2402504Sdlw 	i=d;
2412504Sdlw 	if(x==0.0) goto zero;
2422504Sdlw 	x = abs(x);
2432504Sdlw 	if(x>=0.1)
2442504Sdlw 	{
2452504Sdlw 		for(i=0; i<=d; i++, uplim*=10.0)
2467456Sdlw 		{	if(x>=uplim) continue;
2472504Sdlw zero:			oldscale=scale;
2482504Sdlw 			scale=0;
2492504Sdlw 			ne = e+2;
2502504Sdlw 			if(n = wrt_F(p,w-ne,d-i,len)) return(n);
2512504Sdlw 			for(j=0; j<ne; j++) PUT(' ')
2522504Sdlw 			scale=oldscale;
2532504Sdlw 			return(OK);
2542504Sdlw 		}
2552504Sdlw 		/* falling off the bottom implies E format */
2562504Sdlw 	}
25712039Sdlw 	return(wrt_E(p,w,d,e,len,'e'));
2582504Sdlw }
2592504Sdlw 
2602504Sdlw wrt_F(p,w,d,len) ufloat *p; ftnlen len;
2612504Sdlw {	int i,delta,dp,sign,n,nf;
2622504Sdlw 	double x;
2632504Sdlw 	char *s,*fcvt();
2642504Sdlw 	x= (len==sizeof(float)?(double)p->pf:p->pd);
2652504Sdlw 	if(scale && x!=0.0)
2662504Sdlw 	{	if(scale>0)
2672504Sdlw 			for(i=0;i<scale;i++) x*=10;
2682504Sdlw 		else	for(i=0;i<-scale;i++) x/=10;
2692504Sdlw 	}
2702504Sdlw 	s=fcvt(x,d,&dp,&sign);
2712504Sdlw /*	if(-dp>=d) sign=0; ?? */
2722504Sdlw 	delta=1;
2732504Sdlw 	if(sign || cplus) delta++;
2742504Sdlw 	nf = w - (d + delta + (dp>0?dp:0));
2752504Sdlw 	if(nf<0)
2762504Sdlw 	{
2772504Sdlw 		for(i=0;i<w;i++) PUT('*')
2782504Sdlw 		return(OK);
2792504Sdlw 	}
2802504Sdlw 	if(nf>0) for(i=0; i<(nf-(dp<=0?1:0)); i++) PUT(' ')
2812504Sdlw 	if(sign) PUT('-')
2822504Sdlw 	else if(cplus) PUT('+')
2832504Sdlw 	if(dp>0) for(i=0;i<dp;i++) PUT(*s++)
2842504Sdlw 	else if(nf>0) PUT('0')
2852504Sdlw 	PUT('.')
2862504Sdlw 	for(i=0; i< -dp && i<d; i++) PUT('0')
2872504Sdlw 	for(;i<d;i++)
2883561Sdlw 	{	if(x==0.0 && !cblank) PUT(' ')	/* exactly zero */
2892504Sdlw 		else if(*s) PUT(*s++)
2902504Sdlw 		else PUT('0')
2912504Sdlw 	}
2922504Sdlw 	return(OK);
2932504Sdlw }
294