![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fmt.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / usr.lib / libI77|
Return to fmt.c CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / usr.lib / libI77 |
1.1 root 1: /*
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.
5: *
6: * @(#)fmt.c 5.2 10/22/86
7: */
8:
9: /*
10: * fortran format parser
11: */
12:
13: #include "fio.h"
14: #include "format.h"
15:
16: #define isdigit(x) (x>='0' && x<='9')
17: #define isspace(s) (s==' ')
18: #define skip(s) while(isspace(*s)) s++
19:
20: #ifdef interdata
21: #define SYLMX 300
22: #endif
23:
24: #ifdef pdp11
25: #define SYLMX 300
26: #endif
27:
28: #ifdef vax
29: #define SYLMX 300
30: #endif
31:
32: #ifdef tahoe
33: #define SYLMX 300
34: #endif
35:
36: LOCAL struct syl syl_vec[SYLMX];
37: struct syl *syl_ptr;
38: LOCAL int parenlvl,revloc;
39: int low_case[256];
40: short pc;
41: char *f_s(), *f_list(), *i_tem(), *gt_num(), *ap_end();
42: char *s_init;
43:
44: pars_f()
45: {
46: short *s_ptr;
47: long *l_ptr;
48: int i;
49:
50: /* first time, initialize low_case[] */
51: if( low_case[1] == 0 ) {
52: for(i = 0; i<256; i++) low_case[i]=i;
53: for(i = 'A'; i<='Z'; i++) low_case[i]=i-'A'+'a';
54: }
55:
56: parenlvl=revloc=pc=0;
57:
58: s_ptr = (short *) fmtbuf;
59: if( *s_ptr == FMT_COMP ) {
60: /* already compiled - copy value of pc */
61: pc = *(s_ptr+1);
62: /* get address of the format */
63: l_ptr = (long *) fmtbuf;
64: fmtbuf = s_init = (char *) *(l_ptr+1);
65: /* point syl_ptr to the compiled format */
66: syl_ptr = (struct syl *) (l_ptr + 2);
67: return(OK);
68: } else {
69: syl_ptr = syl_vec;
70: s_init = fmtbuf;
71: return((f_s(fmtbuf,0)==FMTERR)? ERROR : OK);
72: }
73: }
74:
75: LOCAL
76: char *f_s(s,curloc) char *s;
77: {
78: skip(s);
79: if(*s++!='(')
80: {
81: fmtptr = s;
82: return(FMTERR);
83: }
84: if(parenlvl++ ==1) revloc=curloc;
85: op_gen(RET,curloc,0,0,s);
86: if((s=f_list(s))==FMTERR)
87: {
88: return(FMTERR);
89: }
90: skip(s);
91: return(s);
92: }
93:
94: LOCAL
95: char *f_list(s) char *s;
96: {
97: while (*s)
98: { skip(s);
99: if((s=i_tem(s))==FMTERR) return(FMTERR);
100: skip(s);
101: if(*s==',') s++;
102: else if(*s==')')
103: { if(--parenlvl==0)
104: op_gen(REVERT,revloc,0,0,s);
105: else
106: op_gen(GOTO,0,0,0,s);
107: return(++s);
108: }
109: }
110: fmtptr = s;
111: return(FMTERR);
112: }
113:
114: LOCAL
115: char *i_tem(s) char *s;
116: { char *t;
117: int n,curloc;
118: if(*s==')') return(s);
119: if ((n=ne_d(s,&t))==FMTOK)
120: return(t);
121: else if (n==FMTERR)
122: return(FMTERR);
123: if ((n=e_d(s,&t))==FMTOK)
124: return(t);
125: else if (n==FMTERR)
126: return(FMTERR);
127: s=gt_num(s,&n);
128: if (n == 0) { fmtptr = s; return(FMTERR); }
129: curloc = op_gen(STACK,n,0,0,s);
130: return(f_s(s,curloc));
131: }
132:
133: LOCAL
134: ne_d(s,p) char *s,**p;
135: { int n,x,sign=0,pp1,pp2;
136: switch(low_case[*s])
137: {
138: case ':': op_gen(COLON,(int)('\n'),0,0,s); break;
139: #ifndef KOSHER
140: case '$': op_gen(DOLAR,(int)('\0'),0,0,s); break; /*** NOT STANDARD FORTRAN ***/
141: #endif
142: case 'b':
143: switch(low_case[*(s+1)])
144: {
145: case 'n': s++; op_gen(BNZ,0,0,0,s); break;
146: case 'z': s++; op_gen(BNZ,1,0,0,s); break;
147: #ifndef KOSHER
148: default: op_gen(B,0,0,0,s); break; /*** NOT STANDARD FORTRAN ***/
149: #else
150: default: fmtptr = s; return(FMTUNKN);
151: #endif
152: }
153: break;
154: case 's':
155: switch(low_case[*(s+1)])
156: {
157: case 'p': s++; x=SP; pp1=1; pp2=1; break;
158: #ifndef KOSHER
159: case 'u': s++; x=SU; pp1=0; pp2=0; break; /*** NOT STANDARD FORTRAN ***/
160: #endif
161: case 's': s++; x=SS; pp1=0; pp2=1; break;
162: default: x=S; pp1=0; pp2=1; break;
163: }
164: op_gen(x,pp1,pp2,0,s);
165: break;
166: case '/': op_gen(SLASH,0,0,0,s); break;
167:
168: case '-': sign=1; /* OUTRAGEOUS CODING */
169: case '+': s++; /* OUTRAGEOUS CODING */
170: case '0': case '1': case '2': case '3': case '4':
171: case '5': case '6': case '7': case '8': case '9':
172: s=gt_num(s,&n);
173: switch(low_case[*s])
174: {
175: case 'p': if(sign) n= -n; op_gen(P,n,0,0,s); break;
176: #ifndef KOSHER
177: case 'r': if(n<=1) /*** NOT STANDARD FORTRAN ***/
178: { fmtptr = --s; return(FMTERR); }
179: op_gen(R,n,0,0,s); break;
180: case 't': op_gen(T,0,n,0,s); break; /* NOT STANDARD FORT */
181: #endif
182: case 'x': op_gen(X,n,0,0,s); break;
183: case 'h': op_gen(H,n,(s+1)-s_init,0,s);
184: s+=n;
185: break;
186: default: fmtptr = s; return(FMTUNKN);
187: }
188: break;
189: case GLITCH:
190: case '"':
191: case '\'': op_gen(APOS,s-s_init,0,0,s);
192: *p = ap_end(s);
193: return(FMTOK);
194: case 't':
195: switch(low_case[*(s+1)])
196: {
197: case 'l': s++; x=TL; break;
198: case 'r': s++; x=TR; break;
199: default: x=T; break;
200: }
201: if(isdigit(*(s+1))) {s=gt_num(s+1,&n); s--;}
202: #ifdef KOSHER
203: else { fmtptr = s; return(FMTERR); }
204: #else
205: else n = 0; /* NOT STANDARD FORTRAN, should be error */
206: #endif
207: op_gen(x,n,1,0,s);
208: break;
209: case 'x': op_gen(X,1,0,0,s); break;
210: case 'p': op_gen(P,0,0,0,s); break;
211: #ifndef KOSHER
212: case 'r': op_gen(R,10,1,0,s); break; /*** NOT STANDARD FORTRAN ***/
213: #endif
214:
215: default: fmtptr = s; return(FMTUNKN);
216: }
217: s++;
218: *p=s;
219: return(FMTOK);
220: }
221:
222: LOCAL
223: e_d(s,p) char *s,**p;
224: { int n,w,d,e,x=0, rep_count;
225: char *sv=s;
226: char c;
227: s=gt_num(s,&rep_count);
228: if (rep_count == 0) goto ed_err;
229: c = low_case[*s]; s++;
230: switch(c)
231: {
232: case 'd':
233: case 'e':
234: case 'g':
235: s = gt_num(s, &w);
236: if (w==0) goto ed_err;
237: if(*s=='.')
238: { s++;
239: s=gt_num(s,&d);
240: }
241: else d=0;
242: if(low_case[*s] == 'e'
243: #ifndef KOSHER
244: || *s == '.' /*** '.' is NOT STANDARD FORTRAN ***/
245: #endif
246: )
247: { s++;
248: s=gt_num(s,&e);
249: if (e==0 || e>127 || d>127 ) goto ed_err;
250: if(c=='e') n=EE; else if(c=='d') n=DE; else n=GE;
251: op_gen(n,w,d + (e<<8),rep_count,s);
252: }
253: else
254: {
255: if(c=='e') n=E; else if(c=='d') n=D; else n=G;
256: op_gen(n,w,d,rep_count,s);
257: }
258: break;
259: case 'l':
260: s = gt_num(s, &w);
261: if (w==0) goto ed_err;
262: op_gen(L,w,0,rep_count,s);
263: break;
264: case 'a':
265: skip(s);
266: if(isdigit(*s))
267: { s=gt_num(s,&w);
268: #ifdef KOSHER
269: if (w==0) goto ed_err;
270: #else
271: if (w==0) op_gen(A,0,0,rep_count,s);
272: else
273: #endif
274: op_gen(AW,w,0,rep_count,s);
275: break;
276: }
277: op_gen(A,0,0,rep_count,s);
278: break;
279: case 'f':
280: s = gt_num(s, &w);
281: if (w==0) goto ed_err;
282: if(*s=='.')
283: { s++;
284: s=gt_num(s,&d);
285: }
286: else d=0;
287: op_gen(F,w,d,rep_count,s);
288: break;
289: #ifndef KOSHER
290: case 'o': /*** octal format - NOT STANDARD FORTRAN ***/
291: case 'z': /*** hex format - NOT STANDARD FORTRAN ***/
292: #endif
293: case 'i':
294: s = gt_num(s, &w);
295: if (w==0) goto ed_err;
296: if(*s =='.')
297: {
298: s++;
299: s=gt_num(s,&d);
300: x = IM;
301: }
302: else
303: { d = 1;
304: x = I;
305: }
306: #ifndef KOSHER
307: if (c == 'o')
308: op_gen(R,8,1,rep_count,s);
309: else if (c == 'z')
310: op_gen(R,16,1,rep_count,s);
311: #endif
312: op_gen(x,w,d,rep_count,s);
313: #ifndef KOSHER
314: if (c == 'o' || c == 'z')
315: op_gen(R,10,1,rep_count,s);
316: #endif
317: break;
318: default:
319: *p = sv;
320: fmtptr = s;
321: return(FMTUNKN);
322: }
323: *p = s;
324: return(FMTOK);
325: ed_err:
326: fmtptr = --s;
327: return(FMTERR);
328: }
329:
330: LOCAL
331: op_gen(a,b,c,rep,s) char *s;
332: { struct syl *p= &syl_ptr[pc];
333: if(pc>=SYLMX)
334: { fmtptr = s;
335: fatal(F_ERFMT,"format too complex");
336: }
337: if( b>32767 || c>32767 || rep>32767 )
338: { fmtptr = s;
339: fatal("field width or repeat count too large");
340: }
341: #ifdef DEBUG
342: fprintf(stderr,"%3d opgen: %d %d %d %d %c\n",
343: pc,a,b,c,rep,*s==GLITCH?'"':*s); /* for debug */
344: #endif
345: p->op=a;
346: p->p1=b;
347: p->p2=c;
348: p->rpcnt=rep;
349: return(pc++);
350: }
351:
352: LOCAL
353: char *gt_num(s,n) char *s; int *n;
354: { int m=0,a_digit=NO;
355: skip(s);
356: while(isdigit(*s) || isspace(*s))
357: {
358: if (isdigit(*s))
359: {
360: m = 10*m + (*s)-'0';
361: a_digit = YES;
362: }
363: s++;
364: }
365: if(a_digit) *n=m;
366: else *n=1;
367: return(s);
368: }
369:
370: LOCAL
371: char *ap_end(s) char *s;
372: {
373: char quote;
374: quote = *s++;
375: for(;*s;s++)
376: {
377: if(*s==quote && *++s!=quote) return(s);
378: }
379: fmtptr = s;
380: fatal(F_ERFMT,"bad string");
381: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.