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