![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to rdfmt.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 rdfmt.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: #include "fp.h"
5:
6: extern int f__cursor;
7: #ifdef KR_headers
8: extern double atof();
9: #else
10: #undef abs
11: #undef min
12: #undef max
13: #include "stdlib.h"
14: #endif
15:
16: static int
17: #ifdef KR_headers
18: rd_Z(n,w,len) Uint *n; ftnlen len;
19: #else
20: rd_Z(Uint *n, int w, ftnlen len)
21: #endif
22: {
23: long x[9];
24: char *s, *s0, *s1, *se, *t;
25: int ch, i, w1, w2;
26: static char hex[256];
27: static int one = 1;
28: int bad = 0;
29:
30: if (!hex['0']) {
31: s = "0123456789";
32: while(ch = *s++)
33: hex[ch] = ch - '0' + 1;
34: s = "ABCDEF";
35: while(ch = *s++)
36: hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11;
37: }
38: s = s0 = (char *)x;
39: s1 = (char *)&x[4];
40: se = (char *)&x[8];
41: if (len > 4*sizeof(long))
42: return errno = 117;
43: while (w) {
44: GET(ch);
45: if (ch==',' || ch=='\n')
46: break;
47: w--;
48: if (ch > ' ') {
49: if (!hex[ch & 0xff])
50: bad++;
51: *s++ = ch;
52: if (s == se) {
53: /* discard excess characters */
54: for(t = s0, s = s1; t < s1;)
55: *t++ = *s++;
56: s = s1;
57: }
58: }
59: }
60: if (bad)
61: return errno = 115;
62: w = (int)len;
63: w1 = s - s0;
64: w2 = w1+1 >> 1;
65: t = (char *)n;
66: if (*(char *)&one) {
67: /* little endian */
68: t += w - 1;
69: i = -1;
70: }
71: else
72: i = 1;
73: for(; w > w2; t += i, --w)
74: *t = 0;
75: if (!w)
76: return 0;
77: if (w < w2)
78: s0 = s - (w << 1);
79: else if (w1 & 1) {
80: *t = hex[*s0++ & 0xff] - 1;
81: if (!--w)
82: return 0;
83: t += i;
84: }
85: do {
86: *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1;
87: t += i;
88: s0 += 2;
89: }
90: while(--w);
91: return 0;
92: }
93:
94: static int
95: #ifdef KR_headers
96: rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base;
97: #else
98: rd_I(Uint *n, int w, ftnlen len, register int base)
99: #endif
100: { long x;
101: int sign,ch;
102: char s[84], *ps;
103: ps=s; x=0;
104: while (w)
105: {
106: GET(ch);
107: if (ch==',' || ch=='\n') break;
108: *ps=ch; ps++; w--;
109: }
110: *ps='\0';
111: ps=s;
112: while (*ps==' ') ps++;
113: if (*ps=='-') { sign=1; ps++; }
114: else { sign=0; if (*ps=='+') ps++; }
115: loop: while (*ps>='0' && *ps<='9') { x=x*base+(*ps-'0'); ps++; }
116: if (*ps==' ') {if (f__cblank) x *= base; ps++; goto loop;}
117: if(sign) x = -x;
118: if(len==sizeof(integer)) n->il=x;
119: else if(len == sizeof(char)) n->ic = (char)x;
120: #ifdef Allow_TYQUAD
121: else if (len == sizeof(longint)) n->ili = x;
122: #endif
123: else n->is = (short)x;
124: if (*ps) return(errno=115); else return(0);
125: }
126: static int
127: #ifdef KR_headers
128: rd_L(n,w,len) ftnint *n; ftnlen len;
129: #else
130: rd_L(ftnint *n, int w, ftnlen len)
131: #endif
132: { int ch, lv;
133: char s[84], *ps;
134: ps=s;
135: while (w) {
136: GET(ch);
137: if (ch==','||ch=='\n') break;
138: *ps=ch;
139: ps++; w--;
140: }
141: *ps='\0';
142: ps=s; while (*ps==' ') ps++;
143: if (*ps=='.') ps++;
144: if (*ps=='t' || *ps == 'T')
145: lv = 1;
146: else if (*ps == 'f' || *ps == 'F')
147: lv = 0;
148: else return(errno=116);
149: switch(len) {
150: case sizeof(char): *(char *)n = (char)lv; break;
151: case sizeof(short): *(short *)n = (short)lv; break;
152: default: *n = lv;
153: }
154: return 0;
155: }
156:
157: #include "ctype.h"
158:
159: static int
160: #ifdef KR_headers
161: rd_F(p, w, d, len) ufloat *p; ftnlen len;
162: #else
163: rd_F(ufloat *p, int w, int d, ftnlen len)
164: #endif
165: {
166: char s[FMAX+EXPMAXDIGS+4];
167: register int ch;
168: register char *sp, *spe, *sp1;
169: double x;
170: int scale1, se;
171: long e, exp;
172:
173: sp1 = sp = s;
174: spe = sp + FMAX;
175: exp = -d;
176: x = 0.;
177:
178: do {
179: GET(ch);
180: w--;
181: } while (ch == ' ' && w);
182: switch(ch) {
183: case '-': *sp++ = ch; sp1++; spe++;
184: case '+':
185: if (!w) goto zero;
186: --w;
187: GET(ch);
188: }
189: while(ch == ' ') {
190: blankdrop:
191: if (!w--) goto zero; GET(ch); }
192: while(ch == '0')
193: { if (!w--) goto zero; GET(ch); }
194: if (ch == ' ' && f__cblank)
195: goto blankdrop;
196: scale1 = f__scale;
197: while(isdigit(ch)) {
198: digloop1:
199: if (sp < spe) *sp++ = ch;
200: else ++exp;
201: digloop1e:
202: if (!w--) goto done;
203: GET(ch);
204: }
205: if (ch == ' ') {
206: if (f__cblank)
207: { ch = '0'; goto digloop1; }
208: goto digloop1e;
209: }
210: if (ch == '.') {
211: exp += d;
212: if (!w--) goto done;
213: GET(ch);
214: if (sp == sp1) { /* no digits yet */
215: while(ch == '0') {
216: skip01:
217: --exp;
218: skip0:
219: if (!w--) goto done;
220: GET(ch);
221: }
222: if (ch == ' ') {
223: if (f__cblank) goto skip01;
224: goto skip0;
225: }
226: }
227: while(isdigit(ch)) {
228: digloop2:
229: if (sp < spe)
230: { *sp++ = ch; --exp; }
231: digloop2e:
232: if (!w--) goto done;
233: GET(ch);
234: }
235: if (ch == ' ') {
236: if (f__cblank)
237: { ch = '0'; goto digloop2; }
238: goto digloop2e;
239: }
240: }
241: switch(ch) {
242: default:
243: break;
244: case '-': se = 1; goto signonly;
245: case '+': se = 0; goto signonly;
246: case 'e':
247: case 'E':
248: case 'd':
249: case 'D':
250: if (!w--)
251: goto bad;
252: GET(ch);
253: while(ch == ' ') {
254: if (!w--)
255: goto bad;
256: GET(ch);
257: }
258: se = 0;
259: switch(ch) {
260: case '-': se = 1;
261: case '+':
262: signonly:
263: if (!w--)
264: goto bad;
265: GET(ch);
266: }
267: while(ch == ' ') {
268: if (!w--)
269: goto bad;
270: GET(ch);
271: }
272: if (!isdigit(ch))
273: goto bad;
274:
275: e = ch - '0';
276: for(;;) {
277: if (!w--)
278: { ch = '\n'; break; }
279: GET(ch);
280: if (!isdigit(ch)) {
281: if (ch == ' ') {
282: if (f__cblank)
283: ch = '0';
284: else continue;
285: }
286: else
287: break;
288: }
289: e = 10*e + ch - '0';
290: if (e > EXPMAX && sp > sp1)
291: goto bad;
292: }
293: if (se)
294: exp -= e;
295: else
296: exp += e;
297: scale1 = 0;
298: }
299: switch(ch) {
300: case '\n':
301: case ',':
302: break;
303: default:
304: bad:
305: return (errno = 115);
306: }
307: done:
308: if (sp > sp1) {
309: while(*--sp == '0')
310: ++exp;
311: if (exp -= scale1)
312: sprintf(sp+1, "e%ld", exp);
313: else
314: sp[1] = 0;
315: x = atof(s);
316: }
317: zero:
318: if (len == sizeof(real))
319: p->pf = x;
320: else
321: p->pd = x;
322: return(0);
323: }
324:
325:
326: static int
327: #ifdef KR_headers
328: rd_A(p,len) char *p; ftnlen len;
329: #else
330: rd_A(char *p, ftnlen len)
331: #endif
332: { int i,ch;
333: for(i=0;i<len;i++)
334: { GET(ch);
335: *p++=VAL(ch);
336: }
337: return(0);
338: }
339: static int
340: #ifdef KR_headers
341: rd_AW(p,w,len) char *p; ftnlen len;
342: #else
343: rd_AW(char *p, int w, ftnlen len)
344: #endif
345: { int i,ch;
346: if(w>=len)
347: { for(i=0;i<w-len;i++)
348: GET(ch);
349: for(i=0;i<len;i++)
350: { GET(ch);
351: *p++=VAL(ch);
352: }
353: return(0);
354: }
355: for(i=0;i<w;i++)
356: { GET(ch);
357: *p++=VAL(ch);
358: }
359: for(i=0;i<len-w;i++) *p++=' ';
360: return(0);
361: }
362: static int
363: #ifdef KR_headers
364: rd_H(n,s) char *s;
365: #else
366: rd_H(int n, char *s)
367: #endif
368: { int i,ch;
369: for(i=0;i<n;i++)
370: if((ch=(*f__getn)())<0) return(ch);
371: else *s++ = ch=='\n'?' ':ch;
372: return(1);
373: }
374: static int
375: #ifdef KR_headers
376: rd_POS(s) char *s;
377: #else
378: rd_POS(char *s)
379: #endif
380: { char quote;
381: int ch;
382: quote= *s++;
383: for(;*s;s++)
384: if(*s==quote && *(s+1)!=quote) break;
385: else if((ch=(*f__getn)())<0) return(ch);
386: else *s = ch=='\n'?' ':ch;
387: return(1);
388: }
389: #ifdef KR_headers
390: rd_ed(p,ptr,len) struct f__syl *p; char *ptr; ftnlen len;
391: #else
392: rd_ed(struct f__syl *p, char *ptr, ftnlen len)
393: #endif
394: { int ch;
395: for(;f__cursor>0;f__cursor--) if((ch=(*f__getn)())<0) return(ch);
396: if(f__cursor<0)
397: { if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/
398: f__cursor = -f__recpos; /* is this in the standard? */
399: if(f__external == 0) {
400: extern char *f__icptr;
401: f__icptr += f__cursor;
402: }
403: else if(f__curunit && f__curunit->useek)
404: (void) fseek(f__cf,(long) f__cursor,SEEK_CUR);
405: else
406: err(f__elist->cierr,106,"fmt");
407: f__recpos += f__cursor;
408: f__cursor=0;
409: }
410: switch(p->op)
411: {
412: default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op);
413: sig_die(f__fmtbuf, 1);
414: case IM:
415: case I: ch = rd_I((Uint *)ptr,p->p1,len, 10);
416: break;
417:
418: /* O and OM don't work right for character, double, complex, */
419: /* or doublecomplex, and they differ from Fortran 90 in */
420: /* showing a minus sign for negative values. */
421:
422: case OM:
423: case O: ch = rd_I((Uint *)ptr, p->p1, len, 8);
424: break;
425: case L: ch = rd_L((ftnint *)ptr,p->p1,len);
426: break;
427: case A: ch = rd_A(ptr,len);
428: break;
429: case AW:
430: ch = rd_AW(ptr,p->p1,len);
431: break;
432: case E: case EE:
433: case D:
434: case G:
435: case GE:
436: case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2,len);
437: break;
438:
439: /* Z and ZM assume 8-bit bytes. */
440:
441: case ZM:
442: case Z:
443: ch = rd_Z((Uint *)ptr, p->p1, len);
444: break;
445: }
446: if(ch == 0) return(ch);
447: else if(ch == EOF) return(EOF);
448: if (f__cf)
449: clearerr(f__cf);
450: return(errno);
451: }
452: #ifdef KR_headers
453: rd_ned(p) struct f__syl *p;
454: #else
455: rd_ned(struct f__syl *p)
456: #endif
457: {
458: switch(p->op)
459: {
460: default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op);
461: sig_die(f__fmtbuf, 1);
462: case APOS:
463: return(rd_POS(*(char **)&p->p2));
464: case H: return(rd_H(p->p1,*(char **)&p->p2));
465: case SLASH: return((*f__donewrec)());
466: case TR:
467: case X: f__cursor += p->p1;
468: return(1);
469: case T: f__cursor=p->p1-f__recpos - 1;
470: return(1);
471: case TL: f__cursor -= p->p1;
472: if(f__cursor < -f__recpos) /* TL1000, 1X */
473: f__cursor = -f__recpos;
474: return(1);
475: }
476: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.