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