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