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
s_wsle(a)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
t_putc(c)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
e_wsle()47 e_wsle()
48 { int n;
49 PUT('\n')
50 return(OK);
51 }
52
l_write(number,ptr,len,type)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
lwrt_I(in)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
lwrt_L(ln)124 lwrt_L(ln) ftnint ln;
125 { int n;
126 chk_len(LLOGW);
127 return(wrt_L(&ln,LLOGW));
128 }
129
130 LOCAL
lwrt_A(p,len)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
lwrt_F(fn)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
lwrt_D(dn)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
lwrt_C(a,b)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
lwrt_DC(a,b)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
lwrt_0()217 lwrt_0()
218 { int n; char *z = " 0.";
219 chk_len(4);
220 while(*z) PUT(*z++)
221 return(OK);
222 }
223