Commit | Line | Data |
---|---|---|
bae7117f WH |
1 | #include "f2c.h" |
2 | #include "fio.h" | |
3 | #include "fmt.h" | |
fd3fa61c | 4 | #include "local.h" |
bae7117f WH |
5 | extern int f__cursor; |
6 | #ifdef KR_headers | |
7 | extern char *f__icvt(); | |
8 | #else | |
9 | extern char *f__icvt(long, int*, int*, int); | |
10 | #endif | |
11 | int f__hiwater; | |
12 | icilist *f__svic; | |
13 | char *f__icptr; | |
14 | mv_cur(Void) /* shouldn't use fseek because it insists on calling fflush */ | |
15 | /* instead we know too much about stdio */ | |
16 | { | |
17 | if(f__external == 0) { | |
18 | if(f__cursor < 0) { | |
19 | if(f__hiwater < f__recpos) | |
20 | f__hiwater = f__recpos; | |
21 | f__recpos += f__cursor; | |
22 | f__icptr += f__cursor; | |
23 | f__cursor = 0; | |
24 | if(f__recpos < 0) | |
25 | err(f__elist->cierr, 110, "left off"); | |
26 | } | |
27 | else if(f__cursor > 0) { | |
28 | if(f__recpos + f__cursor >= f__svic->icirlen) | |
29 | err(f__elist->cierr, 110, "recend"); | |
30 | if(f__hiwater <= f__recpos) | |
31 | for(; f__cursor > 0; f__cursor--) | |
32 | (*f__putn)(' '); | |
33 | else if(f__hiwater <= f__recpos + f__cursor) { | |
34 | f__cursor -= f__hiwater - f__recpos; | |
35 | f__icptr += f__hiwater - f__recpos; | |
36 | f__recpos = f__hiwater; | |
37 | for(; f__cursor > 0; f__cursor--) | |
38 | (*f__putn)(' '); | |
39 | } | |
40 | else { | |
41 | f__icptr += f__cursor; | |
42 | f__recpos += f__cursor; | |
43 | } | |
44 | f__cursor = 0; | |
45 | } | |
46 | return(0); | |
47 | } | |
48 | if(f__cursor > 0) { | |
49 | if(f__hiwater <= f__recpos) | |
50 | for(;f__cursor>0;f__cursor--) (*f__putn)(' '); | |
51 | else if(f__hiwater <= f__recpos + f__cursor) { | |
52 | #ifndef NON_UNIX_STDIO | |
53 | if(f__cf->_ptr + f__hiwater - f__recpos < buf_end(f__cf)) | |
54 | f__cf->_ptr += f__hiwater - f__recpos; | |
55 | else | |
56 | #endif | |
57 | (void) fseek(f__cf, (long) (f__hiwater - f__recpos), SEEK_CUR); | |
58 | f__cursor -= f__hiwater - f__recpos; | |
59 | f__recpos = f__hiwater; | |
60 | for(; f__cursor > 0; f__cursor--) | |
61 | (*f__putn)(' '); | |
62 | } | |
63 | else { | |
64 | #ifndef NON_UNIX_STDIO | |
65 | if(f__cf->_ptr + f__cursor < buf_end(f__cf)) | |
66 | f__cf->_ptr += f__cursor; | |
67 | else | |
68 | #endif | |
69 | (void) fseek(f__cf, (long)f__cursor, SEEK_CUR); | |
70 | f__recpos += f__cursor; | |
71 | } | |
72 | } | |
73 | if(f__cursor<0) | |
74 | { | |
75 | if(f__cursor+f__recpos<0) err(f__elist->cierr,110,"left off"); | |
76 | #ifndef NON_UNIX_STDIO | |
77 | if(f__cf->_ptr + f__cursor >= f__cf->_base) | |
78 | f__cf->_ptr += f__cursor; | |
79 | else | |
80 | #endif | |
81 | if(f__curunit && f__curunit->useek) | |
82 | (void) fseek(f__cf,(long)f__cursor,SEEK_CUR); | |
83 | else | |
84 | err(f__elist->cierr,106,"fmt"); | |
85 | if(f__hiwater < f__recpos) | |
86 | f__hiwater = f__recpos; | |
87 | f__recpos += f__cursor; | |
88 | f__cursor=0; | |
89 | } | |
90 | return(0); | |
91 | } | |
92 | ||
93 | static int | |
94 | #ifdef KR_headers | |
95 | wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len; | |
96 | #else | |
97 | wrt_Z(Uint *n, int w, int minlen, ftnlen len) | |
98 | #endif | |
99 | { | |
100 | register char *s, *se; | |
101 | register i, w1; | |
102 | static int one = 1; | |
103 | static char hex[] = "0123456789ABCDEF"; | |
104 | s = (char *)n; | |
105 | --len; | |
106 | if (*(char *)&one) { | |
107 | /* little endian */ | |
108 | se = s; | |
109 | s += len; | |
110 | i = -1; | |
111 | } | |
112 | else { | |
113 | se = s + len; | |
114 | i = 1; | |
115 | } | |
116 | for(;; s += i) | |
117 | if (s == se || *s) | |
118 | break; | |
119 | w1 = (i*(se-s) << 1) + 1; | |
120 | if (*s & 0xf0) | |
121 | w1++; | |
122 | if (w1 > w) | |
123 | for(i = 0; i < w; i++) | |
124 | (*f__putn)('*'); | |
125 | else { | |
126 | if ((minlen -= w1) > 0) | |
127 | w1 += minlen; | |
128 | while(--w >= w1) | |
129 | (*f__putn)(' '); | |
130 | while(--minlen >= 0) | |
131 | (*f__putn)('0'); | |
132 | if (!(*s & 0xf0)) { | |
133 | (*f__putn)(hex[*s & 0xf]); | |
134 | if (s == se) | |
135 | return 0; | |
136 | s += i; | |
137 | } | |
138 | for(;; s += i) { | |
139 | (*f__putn)(hex[*s >> 4 & 0xf]); | |
140 | (*f__putn)(hex[*s & 0xf]); | |
141 | if (s == se) | |
142 | break; | |
143 | } | |
144 | } | |
145 | return 0; | |
146 | } | |
147 | ||
148 | static int | |
149 | #ifdef KR_headers | |
150 | wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base; | |
151 | #else | |
152 | wrt_I(Uint *n, int w, ftnlen len, register int base) | |
153 | #endif | |
154 | { int ndigit,sign,spare,i; | |
155 | long x; | |
156 | char *ans; | |
157 | if(len==sizeof(integer)) x=n->il; | |
158 | else if(len == sizeof(char)) x = n->ic; | |
159 | #ifdef Allow_TYQUAD | |
160 | else if (len == sizeof(longint)) x = n->ili; | |
161 | #endif | |
162 | else x=n->is; | |
163 | ans=f__icvt(x,&ndigit,&sign, base); | |
164 | spare=w-ndigit; | |
165 | if(sign || f__cplus) spare--; | |
166 | if(spare<0) | |
167 | for(i=0;i<w;i++) (*f__putn)('*'); | |
168 | else | |
169 | { for(i=0;i<spare;i++) (*f__putn)(' '); | |
170 | if(sign) (*f__putn)('-'); | |
171 | else if(f__cplus) (*f__putn)('+'); | |
172 | for(i=0;i<ndigit;i++) (*f__putn)(*ans++); | |
173 | } | |
174 | return(0); | |
175 | } | |
176 | static int | |
177 | #ifdef KR_headers | |
178 | wrt_IM(n,w,m,len,base) Uint *n; ftnlen len; int base; | |
179 | #else | |
180 | wrt_IM(Uint *n, int w, int m, ftnlen len, int base) | |
181 | #endif | |
182 | { int ndigit,sign,spare,i,xsign; | |
183 | long x; | |
184 | char *ans; | |
185 | if(sizeof(integer)==len) x=n->il; | |
186 | else if(len == sizeof(char)) x = n->ic; | |
187 | else x=n->is; | |
188 | ans=f__icvt(x,&ndigit,&sign, base); | |
189 | if(sign || f__cplus) xsign=1; | |
190 | else xsign=0; | |
191 | if(ndigit+xsign>w || m+xsign>w) | |
192 | { for(i=0;i<w;i++) (*f__putn)('*'); | |
193 | return(0); | |
194 | } | |
195 | if(x==0 && m==0) | |
196 | { for(i=0;i<w;i++) (*f__putn)(' '); | |
197 | return(0); | |
198 | } | |
199 | if(ndigit>=m) | |
200 | spare=w-ndigit-xsign; | |
201 | else | |
202 | spare=w-m-xsign; | |
203 | for(i=0;i<spare;i++) (*f__putn)(' '); | |
204 | if(sign) (*f__putn)('-'); | |
205 | else if(f__cplus) (*f__putn)('+'); | |
206 | for(i=0;i<m-ndigit;i++) (*f__putn)('0'); | |
207 | for(i=0;i<ndigit;i++) (*f__putn)(*ans++); | |
208 | return(0); | |
209 | } | |
210 | static int | |
211 | #ifdef KR_headers | |
212 | wrt_AP(s) char *s; | |
213 | #else | |
214 | wrt_AP(char *s) | |
215 | #endif | |
216 | { char quote; | |
217 | if(f__cursor && mv_cur()) return(mv_cur()); | |
218 | quote = *s++; | |
219 | for(;*s;s++) | |
220 | { if(*s!=quote) (*f__putn)(*s); | |
221 | else if(*++s==quote) (*f__putn)(*s); | |
222 | else return(1); | |
223 | } | |
224 | return(1); | |
225 | } | |
226 | static int | |
227 | #ifdef KR_headers | |
228 | wrt_H(a,s) char *s; | |
229 | #else | |
230 | wrt_H(int a, char *s) | |
231 | #endif | |
232 | { | |
233 | if(f__cursor && mv_cur()) return(mv_cur()); | |
234 | while(a--) (*f__putn)(*s++); | |
235 | return(1); | |
236 | } | |
237 | #ifdef KR_headers | |
238 | wrt_L(n,len, sz) Uint *n; ftnlen sz; | |
239 | #else | |
240 | wrt_L(Uint *n, int len, ftnlen sz) | |
241 | #endif | |
242 | { int i; | |
243 | long x; | |
244 | if(sizeof(long)==sz) x=n->il; | |
245 | else if(sz == sizeof(char)) x = n->ic; | |
246 | else x=n->is; | |
247 | for(i=0;i<len-1;i++) | |
248 | (*f__putn)(' '); | |
249 | if(x) (*f__putn)('T'); | |
250 | else (*f__putn)('F'); | |
251 | return(0); | |
252 | } | |
253 | static int | |
254 | #ifdef KR_headers | |
255 | wrt_A(p,len) char *p; ftnlen len; | |
256 | #else | |
257 | wrt_A(char *p, ftnlen len) | |
258 | #endif | |
259 | { | |
260 | while(len-- > 0) (*f__putn)(*p++); | |
261 | return(0); | |
262 | } | |
263 | static int | |
264 | #ifdef KR_headers | |
265 | wrt_AW(p,w,len) char * p; ftnlen len; | |
266 | #else | |
267 | wrt_AW(char * p, int w, ftnlen len) | |
268 | #endif | |
269 | { | |
270 | while(w>len) | |
271 | { w--; | |
272 | (*f__putn)(' '); | |
273 | } | |
274 | while(w-- > 0) | |
275 | (*f__putn)(*p++); | |
276 | return(0); | |
277 | } | |
278 | ||
279 | static int | |
280 | #ifdef KR_headers | |
281 | wrt_G(p,w,d,e,len) ufloat *p; ftnlen len; | |
282 | #else | |
283 | wrt_G(ufloat *p, int w, int d, int e, ftnlen len) | |
284 | #endif | |
285 | { double up = 1,x; | |
286 | int i,oldscale=f__scale,n,j; | |
287 | x= len==sizeof(real)?p->pf:p->pd; | |
288 | if(x < 0 ) x = -x; | |
289 | if(x<.1) return(wrt_E(p,w,d,e,len)); | |
290 | for(i=0;i<=d;i++,up*=10) | |
291 | { if(x>=up) continue; | |
292 | f__scale=0; | |
293 | if(e==0) n=4; | |
294 | else n=e+2; | |
295 | i=wrt_F(p,w-n,d-i,len); | |
296 | for(j=0;j<n;j++) (*f__putn)(' '); | |
297 | f__scale=oldscale; | |
298 | return(i); | |
299 | } | |
300 | return(wrt_E(p,w,d,e,len)); | |
301 | } | |
302 | #ifdef KR_headers | |
303 | w_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len; | |
304 | #else | |
305 | w_ed(struct syl *p, char *ptr, ftnlen len) | |
306 | #endif | |
307 | { | |
308 | if(f__cursor && mv_cur()) return(mv_cur()); | |
309 | switch(p->op) | |
310 | { | |
311 | default: | |
312 | fprintf(stderr,"w_ed, unexpected code: %d\n", p->op); | |
313 | sig_die(f__fmtbuf, 1); | |
314 | case I: return(wrt_I((Uint *)ptr,p->p1,len, 10)); | |
315 | case IM: | |
316 | return(wrt_IM((Uint *)ptr,p->p1,p->p2,len,10)); | |
317 | ||
318 | /* O and OM don't work right for character, double, complex, */ | |
319 | /* or doublecomplex, and they differ from Fortran 90 in */ | |
320 | /* showing a minus sign for negative values. */ | |
321 | ||
322 | case O: return(wrt_I((Uint *)ptr, p->p1, len, 8)); | |
323 | case OM: | |
324 | return(wrt_IM((Uint *)ptr,p->p1,p->p2,len,8)); | |
325 | case L: return(wrt_L((Uint *)ptr,p->p1, len)); | |
326 | case A: return(wrt_A(ptr,len)); | |
327 | case AW: | |
328 | return(wrt_AW(ptr,p->p1,len)); | |
329 | case D: | |
330 | case E: | |
331 | case EE: | |
332 | return(wrt_E((ufloat *)ptr,p->p1,p->p2,p->p3,len)); | |
333 | case G: | |
334 | case GE: | |
335 | return(wrt_G((ufloat *)ptr,p->p1,p->p2,p->p3,len)); | |
336 | case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2,len)); | |
337 | ||
338 | /* Z and ZM assume 8-bit bytes. */ | |
339 | ||
340 | case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len)); | |
341 | case ZM: | |
342 | return(wrt_Z((Uint *)ptr,p->p1,p->p2,len)); | |
343 | } | |
344 | } | |
345 | #ifdef KR_headers | |
346 | w_ned(p) struct syl *p; | |
347 | #else | |
348 | w_ned(struct syl *p) | |
349 | #endif | |
350 | { | |
351 | switch(p->op) | |
352 | { | |
353 | default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op); | |
354 | sig_die(f__fmtbuf, 1); | |
355 | case SLASH: | |
356 | return((*f__donewrec)()); | |
357 | case T: f__cursor = p->p1-f__recpos - 1; | |
358 | return(1); | |
359 | case TL: f__cursor -= p->p1; | |
360 | if(f__cursor < -f__recpos) /* TL1000, 1X */ | |
361 | f__cursor = -f__recpos; | |
362 | return(1); | |
363 | case TR: | |
364 | case X: | |
365 | f__cursor += p->p1; | |
366 | return(1); | |
367 | case APOS: | |
368 | return(wrt_AP(*(char **)&p->p2)); | |
369 | case H: | |
370 | return(wrt_H(p->p1,*(char **)&p->p2)); | |
371 | } | |
372 | } |