![[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] / 42BSD / usr.lib / libI77|
Return to fmt.c CVS log | Up to [CSRG BSD Unix] / 42BSD / usr.lib / libI77 |
1.1 root 1: /*
2: char id_fmt[] = "@(#)fmt.c 1.4";
3: *
4: * fortran format parser
5: */
6:
7: #include "fio.h"
8: #include "format.h"
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 '\0': op_gen(BN,cblank,0,0,s); break;
97: case 'z': s++; op_gen(BZ,1,0,0,s); break;
98: case 'n': s++;
99: default: op_gen(BN,0,0,0,s); break;
100: }
101: break;
102: case 's':
103: switch(lcase(*(s+1)))
104: {
105: case 'p': s++; x=SP; pp1=1; pp2=1; break;
106: #ifndef KOSHER
107: case 'u': s++; x=SU; pp1=0; pp2=0; break; /*** NOT STANDARD FORTRAN ***/
108: #endif
109: case 's': s++; x=SS; pp1=0; pp2=1; break;
110: default: x=S; pp1=0; pp2=1; break;
111: }
112: op_gen(x,pp1,pp2,0,s);
113: break;
114: case '/': op_gen(SLASH,0,0,0,s); break;
115:
116: case '-': sign=1; /* OUTRAGEOUS CODING */
117: case '+': s++; /* OUTRAGEOUS CODING */
118: case '0': case '1': case '2': case '3': case '4':
119: case '5': case '6': case '7': case '8': case '9':
120: s=gt_num(s,&n);
121: switch(lcase(*s))
122: {
123: case 'p': if(sign) n= -n; op_gen(P,n,0,0,s); break;
124: #ifndef KOSHER
125: case 'r': if(n<=1) /*** NOT STANDARD FORTRAN ***/
126: { fmtptr = s; return(FMTERR); }
127: op_gen(R,n,0,0,s); break;
128: case 't': op_gen(T,0,n,0,s); break; /* NOT STANDARD FORT */
129: #endif
130: case 'x': op_gen(X,n,0,0,s); break;
131: case 'h': op_gen(H,n,(int)(s+1),0,s);
132: s+=n;
133: break;
134: default: fmtptr = s; return(0);
135: }
136: break;
137: case GLITCH:
138: case '"':
139: case '\'': op_gen(APOS,(int)s,0,0,s);
140: *p = ap_end(s);
141: return(FMTOK);
142: case 't':
143: switch(lcase(*(s+1)))
144: {
145: case 'l': s++; x=TL; break;
146: case 'r': s++; x=TR; break;
147: default: x=T; break;
148: }
149: if(isdigit(*(s+1))) {s=gt_num(s+1,&n); s--;}
150: #ifndef KOSHER
151: else n = 0; /* NOT STANDARD FORTRAN, should be error */
152: #endif
153: #ifdef KOSHER
154: fmtptr = s; return(FMTERR);
155: #endif
156: op_gen(x,n,1,0,s);
157: break;
158: case 'x': op_gen(X,1,0,0,s); break;
159: case 'p': op_gen(P,0,0,0,s); break;
160: #ifndef KOSHER
161: case 'r': op_gen(R,10,1,0,s); break; /*** NOT STANDARD FORTRAN ***/
162: #endif
163:
164: default: fmtptr = s; return(0);
165: }
166: s++;
167: *p=s;
168: return(FMTOK);
169: }
170:
171: e_d(s,p) char *s,**p;
172: { int n,w,d,e,x=0;
173: char *sv=s;
174: char c;
175: s=gt_num(s,&n);
176: op_gen(STACK,n,0,0,s);
177: c = lcase(*s); s++;
178: switch(c)
179: {
180: case 'd':
181: case 'e':
182: case 'g':
183: s = gt_num(s, &w);
184: if (w==0) break;
185: if(*s=='.')
186: { s++;
187: s=gt_num(s,&d);
188: }
189: else d=0;
190: if(lcase(*s) == 'e'
191: #ifndef KOSHER
192: || *s == '.' /*** '.' is NOT STANDARD FORTRAN ***/
193: #endif
194: )
195: { s++;
196: s=gt_num(s,&e);
197: if(c=='e') n=EE; else if(c=='d') n=DE; else n=GE;
198: }
199: else
200: { e=2;
201: if(c=='e') n=E; else if(c=='d') n=D; else n=G;
202: }
203: op_gen(n,w,d,e,s);
204: break;
205: case 'l':
206: s = gt_num(s, &w);
207: if (w==0) break;
208: op_gen(L,w,0,0,s);
209: break;
210: case 'a':
211: skip(s);
212: if(*s>='0' && *s<='9')
213: { s=gt_num(s,&w);
214: if(w==0) break;
215: op_gen(AW,w,0,0,s);
216: break;
217: }
218: op_gen(A,0,0,0,s);
219: break;
220: case 'f':
221: s = gt_num(s, &w);
222: if (w==0) break;
223: if(*s=='.')
224: { s++;
225: s=gt_num(s,&d);
226: }
227: else d=0;
228: op_gen(F,w,d,0,s);
229: break;
230: case 'i':
231: s = gt_num(s, &w);
232: if (w==0) break;
233: if(*s =='.')
234: {
235: s++;
236: s=gt_num(s,&d);
237: x = IM;
238: }
239: else
240: { d = 1;
241: x = I;
242: }
243: op_gen(x,w,d,0,s);
244: break;
245: default:
246: pc--; /* unSTACK */
247: *p = sv;
248: fmtptr = s;
249: return(FMTERR);
250: }
251: *p = s;
252: return(FMTOK);
253: }
254:
255: op_gen(a,b,c,d,s) char *s;
256: { struct syl *p= &syl[pc];
257: if(pc>=SYLMX)
258: { fmtptr = s;
259: fatal(F_ERFMT,"format too complex");
260: }
261: #ifdef DEBUG
262: fprintf(stderr,"%3d opgen: %d %d %d %d %c\n",
263: pc,a,b,c,d,*s==GLITCH?'"':*s); /* for debug */
264: #endif
265: p->op=a;
266: p->p1=b;
267: p->p2=c;
268: p->p3=d;
269: return(pc++);
270: }
271:
272: char *gt_num(s,n) char *s; int *n;
273: { int m=0,a_digit=NO;
274: skip(s);
275: while(isdigit(*s) || isspace(*s))
276: {
277: if (isdigit(*s))
278: {
279: m = 10*m + (*s)-'0';
280: a_digit = YES;
281: }
282: s++;
283: }
284: if(a_digit) *n=m;
285: else *n=1;
286: return(s);
287: }
288:
289: char *ap_end(s) char *s;
290: {
291: char quote;
292: quote = *s++;
293: for(;*s;s++)
294: {
295: if(*s==quote && *++s!=quote) return(s);
296: }
297: fmtptr = s;
298: fatal(F_ERFMT,"bad string");
299: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.