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