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