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