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