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