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