xref: /csrg-svn/usr.bin/f77/libI77/lwrite.c (revision 12040)
12497Sdlw /*
2*12040Sdlw char id_lwrite[] = "@(#)lwrite.c	1.4";
32497Sdlw  *
42497Sdlw  * list directed write
52497Sdlw  */
62497Sdlw 
72497Sdlw #include "fio.h"
82497Sdlw #include "lio.h"
92497Sdlw 
102497Sdlw int l_write(), t_putc();
114118Sdlw char lwrt[] = "list write";
122497Sdlw 
132497Sdlw s_wsle(a) cilist *a;
142497Sdlw {
152497Sdlw 	int n;
162497Sdlw 	reading = NO;
172497Sdlw 	if(n=c_le(a,WRITE)) return(n);
182497Sdlw 	putn = t_putc;
192497Sdlw 	lioproc = l_write;
202497Sdlw 	line_len = LINE;
212497Sdlw 	curunit->uend = NO;
222497Sdlw 	leof = NO;
234118Sdlw 	if(!curunit->uwrt && ! nowwriting(curunit)) err(errflag, errno, lwrt)
242497Sdlw 	return(OK);
252497Sdlw }
262497Sdlw 
272497Sdlw t_putc(c) char c;
282497Sdlw {
292497Sdlw 	if(c=='\n') recpos=0;
302497Sdlw 	else recpos++;
312497Sdlw 	putc(c,cf);
322497Sdlw 	return(OK);
332497Sdlw }
342497Sdlw 
352497Sdlw e_wsle()
362497Sdlw {	int n;
372497Sdlw 	PUT('\n')
382497Sdlw 	return(OK);
392497Sdlw }
402497Sdlw 
412497Sdlw l_write(number,ptr,len,type) ftnint *number,type; flex *ptr; ftnlen len;
422497Sdlw {
432497Sdlw 	int i,n;
442497Sdlw 	ftnint x;
452497Sdlw 	float y,z;
462497Sdlw 	double yd,zd;
472497Sdlw 	float *xx;
482497Sdlw 	double *yy;
492497Sdlw 	for(i=0;i< *number; i++)
502497Sdlw 	{
512497Sdlw 		switch((int)type)
522497Sdlw 		{
532497Sdlw 		case TYSHORT:
542497Sdlw 			x=ptr->flshort;
552497Sdlw 			goto xint;
562497Sdlw 		case TYLONG:
572497Sdlw 			x=ptr->flint;
582497Sdlw 	xint:		ERR(lwrt_I(x));
592497Sdlw 			break;
602497Sdlw 		case TYREAL:
612497Sdlw 			ERR(lwrt_F(ptr->flreal));
622497Sdlw 			break;
632497Sdlw 		case TYDREAL:
642497Sdlw 			ERR(lwrt_D(ptr->fldouble));
652497Sdlw 			break;
662497Sdlw 		case TYCOMPLEX:
672497Sdlw 			xx= &(ptr->flreal);
682497Sdlw 			y = *xx++;
692497Sdlw 			z = *xx;
702497Sdlw 			ERR(lwrt_C(y,z));
712497Sdlw 			break;
722497Sdlw 		case TYDCOMPLEX:
732497Sdlw 			yy = &(ptr->fldouble);
742497Sdlw 			yd= *yy++;
752497Sdlw 			zd = *yy;
762497Sdlw 			ERR(lwrt_DC(yd,zd));
772497Sdlw 			break;
782497Sdlw 		case TYLOGICAL:
792497Sdlw 			ERR(lwrt_L(ptr->flint));
802497Sdlw 			break;
812497Sdlw 		case TYCHAR:
822497Sdlw 			ERR(lwrt_A((char *)ptr,len));
832497Sdlw 			break;
842497Sdlw 		default:
852596Sdlw 			fatal(F_ERSYS,"unknown type in lwrite");
862497Sdlw 		}
872497Sdlw 		ptr = (flex *)((char *)ptr + len);
882497Sdlw 	}
892497Sdlw 	return(OK);
902497Sdlw }
912497Sdlw 
922497Sdlw lwrt_I(in) ftnint in;
932497Sdlw {	int n;
942497Sdlw 	char buf[16],*p;
952497Sdlw 	sprintf(buf,"  %ld",(long)in);
962497Sdlw 	if(n=chk_len(LINTW)) return(n);
972497Sdlw 	for(p=buf;*p;) PUT(*p++)
982497Sdlw 	return(OK);
992497Sdlw }
1002497Sdlw 
1012497Sdlw lwrt_L(ln) ftnint ln;
1022497Sdlw {	int n;
1032497Sdlw 	if(n=chk_len(LLOGW)) return(n);
1042497Sdlw 	return(wrt_L(&ln,LLOGW));
1052497Sdlw }
1062497Sdlw 
1072497Sdlw lwrt_A(p,len) char *p; ftnlen len;
1082497Sdlw {	int i,n;
1092497Sdlw 	if(n=chk_len(LSTRW)) return(n);
1102497Sdlw 	PUT(' ')
1112497Sdlw 	PUT(' ')
1122497Sdlw 	for(i=0;i<len;i++) PUT(*p++)
1132497Sdlw 	return(OK);
1142497Sdlw }
1152497Sdlw 
1162497Sdlw lwrt_F(fn) float fn;
1172497Sdlw {	int d,n; float x; ufloat f;
1182497Sdlw 	if(fn==0.0) return(lwrt_0());
1192497Sdlw 	f.pf = fn;
1202497Sdlw 	d = width(fn);
1212497Sdlw 	if(n=chk_len(d)) return(n);
1222497Sdlw 	if(d==LFW)
1232497Sdlw 	{
1242497Sdlw 		scale = 0;
1252497Sdlw 		for(d=LFD,x=abs(fn);x>=1.0;x/=10.0,d--);
1262497Sdlw 		return(wrt_F(&f,LFW,d,(ftnlen)sizeof(float)));
1272497Sdlw 	}
1282497Sdlw 	else
1292497Sdlw 	{
1302497Sdlw 		scale = 1;
131*12040Sdlw 		return(wrt_E(&f,LEW,LED-scale,LEE,(ftnlen)sizeof(float),'e'));
1322497Sdlw 	}
1332497Sdlw }
1342497Sdlw 
1352497Sdlw lwrt_D(dn) double dn;
1362497Sdlw {	int d,n; double x; ufloat f;
1372497Sdlw 	if(dn==0.0) return(lwrt_0());
1382497Sdlw 	f.pd = dn;
1392497Sdlw 	d = dwidth(dn);
1402497Sdlw 	if(n=chk_len(d)) return(n);
1412497Sdlw 	if(d==LDFW)
1422497Sdlw 	{
1432497Sdlw 		scale = 0;
1442497Sdlw 		for(d=LDFD,x=abs(dn);x>=1.0;x/=10.0,d--);
1452497Sdlw 		return(wrt_F(&f,LDFW,d,(ftnlen)sizeof(double)));
1462497Sdlw 	}
1472497Sdlw 	else
1482497Sdlw 	{
1492497Sdlw 		scale = 1;
150*12040Sdlw 		return(wrt_E(&f,LDEW,LDED-scale,LDEE,(ftnlen)sizeof(double),'d'));
1512497Sdlw 	}
1522497Sdlw }
1532497Sdlw 
1542497Sdlw lwrt_C(a,b) float a,b;
1552497Sdlw {	int n;
1562497Sdlw 	if(n=chk_len(LCW)) return(n);
1572497Sdlw 	PUT(' ')
1582497Sdlw 	PUT(' ')
1592497Sdlw 	PUT('(')
1602497Sdlw 	if(n=lwrt_F(a)) return(n);
1612497Sdlw 	PUT(',')
1622497Sdlw 	if(n=lwrt_F(b)) return(n);
1632497Sdlw 	PUT(')')
1642497Sdlw 	return(OK);
1652497Sdlw }
1662497Sdlw 
1672497Sdlw lwrt_DC(a,b) double a,b;
1682497Sdlw {	int n;
1692497Sdlw 	if(n=chk_len(LDCW)) return(n);
1702497Sdlw 	PUT(' ')
1712497Sdlw 	PUT(' ')
1722497Sdlw 	PUT('(')
1732497Sdlw 	if(n=lwrt_D(a)) return(n);
1742497Sdlw 	PUT(',')
1752497Sdlw 	if(n=lwrt_D(b)) return(n);
1762497Sdlw 	PUT(')')
1772497Sdlw 	return(OK);
1782497Sdlw }
1792497Sdlw 
1802497Sdlw lwrt_0()
1812497Sdlw {	int n; char *z = "  0.";
1822497Sdlw 	if(n=chk_len(4)) return(n);
1832497Sdlw 	while(*z) PUT(*z++)
1842497Sdlw 	return(OK);
1852497Sdlw }
1862497Sdlw 
1872497Sdlw chk_len(w)
1882497Sdlw {	int n;
1892497Sdlw 	if(recpos+w > line_len) PUT('\n')
1902497Sdlw 	return(OK);
1912497Sdlw }
192