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