1 /*- 2 * Copyright (c) 1980 The Regents of the University of California. 3 * All rights reserved. 4 * 5 * %sccs.include.proprietary.c% 6 */ 7 8 #ifndef lint 9 static char sccsid[] = "@(#)lwrite.c 5.4 (Berkeley) 04/12/91"; 10 #endif /* not lint */ 11 12 /* 13 * list directed write 14 */ 15 16 #include "fio.h" 17 #include "lio.h" 18 19 int l_write(), t_putc(); 20 LOCAL char lwrt[] = "list write"; 21 22 s_wsle(a) cilist *a; 23 { 24 int n; 25 reading = NO; 26 formatted = LISTDIRECTED; 27 fmtbuf = "ext list io"; 28 if(n=c_le(a,WRITE)) return(n); 29 putn = t_putc; 30 lioproc = l_write; 31 line_len = LINE; 32 curunit->uend = NO; 33 leof = NO; 34 if(!curunit->uwrt && ! nowwriting(curunit)) err(errflag, errno, lwrt) 35 return(OK); 36 } 37 38 LOCAL 39 t_putc(c) char c; 40 { 41 if(c=='\n') recpos=0; 42 else recpos++; 43 putc(c,cf); 44 return(OK); 45 } 46 47 e_wsle() 48 { int n; 49 PUT('\n') 50 return(OK); 51 } 52 53 l_write(number,ptr,len,type) ftnint *number,type; flex *ptr; ftnlen len; 54 { 55 int i,n; 56 ftnint x; 57 float y,z; 58 double yd,zd; 59 float *xx; 60 double *yy; 61 for(i=0;i< *number; i++) 62 { 63 if( formatted == NAMELIST && i != 0 ) PUT(','); 64 switch((int)type) 65 { 66 case TYSHORT: 67 x=ptr->flshort; 68 goto xint; 69 case TYLONG: 70 x=ptr->flint; 71 xint: ERRCHK(lwrt_I(x)); 72 break; 73 case TYREAL: 74 ERRCHK(lwrt_F(ptr->flreal)); 75 break; 76 case TYDREAL: 77 ERRCHK(lwrt_D(ptr->fldouble)); 78 break; 79 case TYCOMPLEX: 80 xx= &(ptr->flreal); 81 y = *xx++; 82 z = *xx; 83 ERRCHK(lwrt_C(y,z)); 84 break; 85 case TYDCOMPLEX: 86 yy = &(ptr->fldouble); 87 yd= *yy++; 88 zd = *yy; 89 ERRCHK(lwrt_DC(yd,zd)); 90 break; 91 case TYLOGICAL: 92 if(len == sizeof(short)) 93 x = ptr->flshort; 94 else 95 x = ptr->flint; 96 ERRCHK(lwrt_L(x)); 97 break; 98 case TYCHAR: 99 ERRCHK(lwrt_A((char *)ptr,len)); 100 break; 101 default: 102 fatal(F_ERSYS,"unknown type in lwrite"); 103 } 104 ptr = (flex *)((char *)ptr + len); 105 } 106 return(OK); 107 108 got_err: 109 err( n>0?errflag:endflag, n, 110 formatted==LISTDIRECTED?"list io":"name list io"); 111 } 112 113 LOCAL 114 lwrt_I(in) ftnint in; 115 { int n; 116 char buf[16],*p; 117 sprintf(buf," %ld",(long)in); 118 chk_len(LINTW); 119 for(p=buf;*p;) PUT(*p++) 120 return(OK); 121 } 122 123 LOCAL 124 lwrt_L(ln) ftnint ln; 125 { int n; 126 chk_len(LLOGW); 127 return(wrt_L(&ln,LLOGW)); 128 } 129 130 LOCAL 131 lwrt_A(p,len) char *p; ftnlen len; 132 { int i,n; 133 if(formatted == LISTDIRECTED) 134 { 135 chk_len(len); 136 for(i=0;i<len;i++) PUT(*p++) 137 } 138 else 139 { 140 chk_len(len+2); 141 PUT('\'') 142 for(i=0;i<len;i++) PUT(*p++) 143 PUT('\'') 144 } 145 return(OK); 146 } 147 148 LOCAL 149 lwrt_F(fn) float fn; 150 { int d,n; float x; ufloat f; 151 if(fn==0.0) return(lwrt_0()); 152 f.pf = fn; 153 d = width(fn); 154 chk_len(d); 155 if(d==LFW) 156 { 157 scale = 0; 158 for(d=LFD,x=abs(fn);x>=1.0;x/=10.0,d--); 159 return(wrt_F(&f,LFW,d,(ftnlen)sizeof(float))); 160 } 161 else 162 { 163 scale = 1; 164 return(wrt_E(&f,LEW,LED-scale,LEE,(ftnlen)sizeof(float),'e')); 165 } 166 } 167 168 LOCAL 169 lwrt_D(dn) double dn; 170 { int d,n; double x; ufloat f; 171 if(dn==0.0) return(lwrt_0()); 172 f.pd = dn; 173 d = dwidth(dn); 174 chk_len(d); 175 if(d==LDFW) 176 { 177 scale = 0; 178 for(d=LDFD,x=abs(dn);x>=1.0;x/=10.0,d--); 179 return(wrt_F(&f,LDFW,d,(ftnlen)sizeof(double))); 180 } 181 else 182 { 183 scale = 1; 184 return(wrt_E(&f,LDEW,LDED-scale,LDEE,(ftnlen)sizeof(double),'d')); 185 } 186 } 187 188 LOCAL 189 lwrt_C(a,b) float a,b; 190 { int n; 191 chk_len(LCW); 192 PUT(' ') 193 PUT(' ') 194 PUT('(') 195 if(n=lwrt_F(a)) return(n); 196 PUT(',') 197 if(n=lwrt_F(b)) return(n); 198 PUT(')') 199 return(OK); 200 } 201 202 LOCAL 203 lwrt_DC(a,b) double a,b; 204 { int n; 205 chk_len(LDCW); 206 PUT(' ') 207 PUT(' ') 208 PUT('(') 209 if(n=lwrt_D(a)) return(n); 210 PUT(',') 211 if(n=lwrt_D(b)) return(n); 212 PUT(')') 213 return(OK); 214 } 215 216 LOCAL 217 lwrt_0() 218 { int n; char *z = " 0."; 219 chk_len(4); 220 while(*z) PUT(*z++) 221 return(OK); 222 } 223