![[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] / 40BSD / lib / libI77uc|
Return to fmt.c CVS log | Up to [CSRG BSD Unix] / 40BSD / lib / libI77uc |
1.1 root 1: /*
2: * fortran format parser
3: */
4:
5: #include "fio.h"
6: #include "fmt.h"
7:
8: #define isdigit(x) (x>='0' && x<='9')
9: #define isspace(s) (s==' ')
10: #define skip(s) while(isspace(*s)) s++
11:
12: #ifdef interdata
13: #define SYLMX 300
14: #endif
15:
16: #ifdef pdp11
17: #define SYLMX 300
18: #endif
19:
20: #ifdef vax
21: #define SYLMX 300
22: #endif
23:
24: struct syl syl[SYLMX];
25: int parenlvl,pc,revloc;
26: char *f_s(), *f_list(), *i_tem(), *gt_num(), *ap_end();
27:
28: pars_f(s) char *s;
29: {
30: parenlvl=revloc=pc=0;
31: return((f_s(s,0)==FMTERR)? ERROR : OK);
32: }
33:
34: char *f_s(s,curloc) char *s;
35: {
36: skip(s);
37: if(*s++!='(')
38: {
39: fmtptr = s;
40: return(FMTERR);
41: }
42: if(parenlvl++ ==1) revloc=curloc;
43: op_gen(RET,curloc,0,0,s);
44: if((s=f_list(s))==FMTERR)
45: {
46: return(FMTERR);
47: }
48: skip(s);
49: return(s);
50: }
51:
52: char *f_list(s) char *s;
53: {
54: while (*s)
55: { skip(s);
56: if((s=i_tem(s))==FMTERR) return(FMTERR);
57: skip(s);
58: if(*s==',') s++;
59: else if(*s==')')
60: { if(--parenlvl==0)
61: {
62: op_gen(REVERT,revloc,0,0,s);
63: }
64: else op_gen(GOTO,0,0,0,s);
65: return(++s);
66: }
67: }
68: fmtptr = s;
69: return(FMTERR);
70: }
71:
72: char *i_tem(s) char *s;
73: { char *t;
74: int n,curloc;
75: if(*s==')') return(s);
76: if(ne_d(s,&t)) return(t);
77: if(e_d(s,&t)) return(t);
78: s=gt_num(s,&n);
79: curloc = op_gen(STACK,n,0,0,s);
80: return(f_s(s,curloc));
81: }
82:
83: ne_d(s,p) char *s,**p;
84: { int n,x,sign=0,pp1,pp2;
85: switch(lcase(*s))
86: {
87: case ':': op_gen(COLON,(int)('\n'),0,0,s); break;
88: #ifndef KOSHER
89: case '$': op_gen(DOLAR,(int)('\0'),0,0,s); break; /*** NOT STANDARD FORTRAN ***/
90: #endif
91: case 'b':
92: switch(lcase(*(s+1)))
93: {
94: case 'z': s++; op_gen(BZ,1,0,0,s); break;
95: case 'n': s++;
96: default: op_gen(BN,0,0,0,s); break;
97: }
98: break;
99: case 's':
100: switch(lcase(*(s+1)))
101: {
102: case 'p': s++; x=SP; pp1=1; pp2=1; break;
103: #ifndef KOSHER
104: case 'u': s++; x=SU; pp1=0; pp2=0; break; /*** NOT STANDARD FORTRAN ***/
105: #endif
106: case 's': s++; x=SS; pp1=0; pp2=1; break;
107: default: x=S; pp1=0; pp2=1; break;
108: }
109: op_gen(x,pp1,pp2,0,s);
110: break;
111: case '/': op_gen(SLASH,0,0,0,s); break;
112: case '-': sign=1; s++; /*OUTRAGEOUS CODING TRICK*/
113: case '0': case '1': case '2': case '3': case '4':
114: case '5': case '6': case '7': case '8': case '9':
115: s=gt_num(s,&n);
116: switch(lcase(*s))
117: {
118: case 'p': if(sign) n= -n; op_gen(P,n,0,0,s); break;
119: #ifndef KOSHER
120: case 'r': if(n<=1) /*** NOT STANDARD FORTRAN ***/
121: { fmtptr = s; return(FMTERR); }
122: op_gen(R,n,0,0,s); break;
123: case 't': op_gen(T,0,n,0,s); break; /* NOT STANDARD FORT */
124: #endif
125: case 'x': op_gen(X,n,0,0,s); break;
126: case 'h': op_gen(H,n,(int)(s+1),0,s);
127: s+=n;
128: break;
129: default: fmtptr = s; return(0);
130: }
131: break;
132: case GLITCH:
133: case '"':
134: case '\'': op_gen(APOS,(int)s,0,0,s);
135: *p = ap_end(s);
136: return(FMTOK);
137: case 't':
138: switch(lcase(*(s+1)))
139: {
140: case 'l': s++; x=TL; break;
141: case 'r': s++; x=TR; break;
142: default: x=T; break;
143: }
144: if(isdigit(*(s+1))) {s=gt_num(s+1,&n); s--;}
145: #ifndef KOSHER
146: else n = 0; /* NOT STANDARD FORTRAN, should be error */
147: #endif
148: #ifdef KOSHER
149: fmtptr = s; return(FMTERR);
150: #endif
151: op_gen(x,n,1,0,s);
152: break;
153: case 'x': op_gen(X,1,0,0,s); break;
154: case 'p': op_gen(P,0,0,0,s); break;
155: #ifndef KOSHER
156: case 'r': op_gen(R,10,1,0,s); break; /*** NOT STANDARD FORTRAN ***/
157: #endif
158:
159: default: fmtptr = s; return(0);
160: }
161: s++;
162: *p=s;
163: return(FMTOK);
164: }
165:
166: e_d(s,p) char *s,**p;
167: { int n,w,d,e,x=0;
168: char *sv=s;
169: char c;
170: s=gt_num(s,&n);
171: op_gen(STACK,n,0,0,s);
172: c = lcase(*s); s++;
173: switch(c)
174: {
175: case 'd':
176: case 'e':
177: case 'g':
178: s = gt_num(s, &w);
179: if (w==0) break;
180: if(*s=='.')
181: { s++;
182: s=gt_num(s,&d);
183: }
184: else d=0;
185: if(lcase(*s) == 'e'
186: #ifndef KOSHER
187: || *s == '.' /*** '.' is NOT STANDARD FORTRAN ***/
188: #endif
189: )
190: { s++;
191: s=gt_num(s,&e);
192: if(c=='e') n=EE; else if(c=='d') n=DE; else n=GE;
193: }
194: else
195: { e=2;
196: if(c=='e') n=E; else if(c=='d') n=D; else n=G;
197: }
198: op_gen(n,w,d,e,s);
199: break;
200: case 'l':
201: s = gt_num(s, &w);
202: if (w==0) break;
203: op_gen(L,w,0,0,s);
204: break;
205: case 'a':
206: skip(s);
207: if(*s>='0' && *s<='9')
208: { s=gt_num(s,&w);
209: if(w==0) break;
210: op_gen(AW,w,0,0,s);
211: break;
212: }
213: op_gen(A,0,0,0,s);
214: break;
215: case 'f':
216: s = gt_num(s, &w);
217: if (w==0) break;
218: if(*s=='.')
219: { s++;
220: s=gt_num(s,&d);
221: }
222: else d=0;
223: op_gen(F,w,d,0,s);
224: break;
225: case 'i':
226: s = gt_num(s, &w);
227: if (w==0) break;
228: if(*s =='.')
229: {
230: s++;
231: s=gt_num(s,&d);
232: x = IM;
233: }
234: else
235: { d = 1;
236: x = I;
237: }
238: op_gen(x,w,d,0,s);
239: break;
240: default:
241: pc--; /* unSTACK */
242: *p = sv;
243: fmtptr = s;
244: return(FMTERR);
245: }
246: *p = s;
247: return(FMTOK);
248: }
249:
250: op_gen(a,b,c,d,s) char *s;
251: { struct syl *p= &syl[pc];
252: if(pc>=SYLMX)
253: { fmtptr = s;
254: fatal(100,"format too complex");
255: }
256: #ifdef debug
257: fprintf(stderr,"%3d opgen: %d %d %d %d %c\n",
258: pc,a,b,c,d,*s==GLITCH?'"':*s); /* for debug */
259: #endif
260: p->op=a;
261: p->p1=b;
262: p->p2=c;
263: p->p3=d;
264: return(pc++);
265: }
266:
267: char *gt_num(s,n) char *s; int *n;
268: { int m=0,a_digit=NO;
269: skip(s);
270: while(isdigit(*s) || isspace(*s))
271: {
272: if (isdigit(*s))
273: {
274: m = 10*m + (*s)-'0';
275: a_digit = YES;
276: }
277: s++;
278: }
279: if(a_digit) *n=m;
280: else *n=1;
281: return(s);
282: }
283:
284: char *ap_end(s) char *s;
285: {
286: char quote;
287: quote = *s++;
288: for(;*s;s++)
289: {
290: if(*s==quote && *++s!=quote) return(s);
291: }
292: fmtptr = s;
293: fatal(100,"bad string");
294: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.