[unix-history] / usr / src / usr.bin / f77 / libI77 / fmt.c

/*
char id_fmt[] = "@(#)fmt.c	1.2";
 *
 * fortran format parser
 */

#include "fio.h"
#include "format.h"

#define isdigit(x)	(x>='0' && x<='9')
#define isspace(s)	(s==' ')
#define skip(s)		while(isspace(*s)) s++

#ifdef interdata
#define SYLMX 300
#endif

#ifdef pdp11
#define SYLMX 300
#endif

#ifdef vax
#define SYLMX 300
#endif

struct syl syl[SYLMX];
int parenlvl,pc,revloc;
char *f_s(), *f_list(), *i_tem(), *gt_num(), *ap_end();

pars_f(s) char *s;
{
	parenlvl=revloc=pc=0;
	return((f_s(s,0)==FMTERR)? ERROR : OK);
}

char *f_s(s,curloc) char *s;
{
	skip(s);
	if(*s++!='(')
	{
		fmtptr = s;
		return(FMTERR);
	}
	if(parenlvl++ ==1) revloc=curloc;
	op_gen(RET,curloc,0,0,s);
	if((s=f_list(s))==FMTERR)
	{
		return(FMTERR);
	}
	skip(s);
	return(s);
}

char *f_list(s) char *s;
{
	while (*s)
	{	skip(s);
		if((s=i_tem(s))==FMTERR) return(FMTERR);
		skip(s);
		if(*s==',') s++;
		else if(*s==')')
		{	if(--parenlvl==0)
			{
				op_gen(REVERT,revloc,0,0,s);
			}
			else	op_gen(GOTO,0,0,0,s);
			return(++s);
		}
	}
	fmtptr = s;
	return(FMTERR);
}

char *i_tem(s) char *s;
{	char *t;
	int n,curloc;
	if(*s==')') return(s);
	if(ne_d(s,&t)) return(t);
	if(e_d(s,&t)) return(t);
	s=gt_num(s,&n);
	curloc = op_gen(STACK,n,0,0,s);
	return(f_s(s,curloc));
}

ne_d(s,p) char *s,**p;
{	int n,x,sign=0,pp1,pp2;
	switch(lcase(*s))
	{
	case ':': op_gen(COLON,(int)('\n'),0,0,s); break;
#ifndef KOSHER
	case '$': op_gen(DOLAR,(int)('\0'),0,0,s); break;  /*** NOT STANDARD FORTRAN ***/
#endif
	case 'b':
		switch(lcase(*(s+1)))
		{
			case 'z': s++; op_gen(BZ,1,0,0,s); break;
			case 'n': s++;
			default:  op_gen(BN,0,0,0,s); break;
		}
		break;
	case 's':
		switch(lcase(*(s+1)))
		{
			case 'p': s++; x=SP; pp1=1; pp2=1; break;
#ifndef KOSHER
			case 'u': s++; x=SU; pp1=0; pp2=0; break;  /*** NOT STANDARD FORTRAN ***/
#endif
			case 's': s++; x=SS; pp1=0; pp2=1; break;
			default:  x=S; pp1=0; pp2=1; break;
		}
		op_gen(x,pp1,pp2,0,s);
		break;
	case '/': op_gen(SLASH,0,0,0,s); break;
	case '-': sign=1; s++;	/*OUTRAGEOUS CODING TRICK*/
	case '0': case '1': case '2': case '3': case '4':
	case '5': case '6': case '7': case '8': case '9':
		s=gt_num(s,&n);
		switch(lcase(*s))
		{
		case 'p': if(sign) n= -n; op_gen(P,n,0,0,s); break;
#ifndef KOSHER
		case 'r': if(n<=1)		/*** NOT STANDARD FORTRAN ***/
			{	fmtptr = s; return(FMTERR); }
			op_gen(R,n,0,0,s); break;
		case 't': op_gen(T,0,n,0,s); break;	/* NOT STANDARD FORT */
#endif
		case 'x': op_gen(X,n,0,0,s); break;
		case 'h': op_gen(H,n,(int)(s+1),0,s);
			s+=n;
			break;
		default: fmtptr = s; return(0);
		}
		break;
	case GLITCH:
	case '"':
	case '\'': op_gen(APOS,(int)s,0,0,s);
		*p = ap_end(s);
		return(FMTOK);
	case 't':
		switch(lcase(*(s+1)))
		{
			case 'l': s++; x=TL; break;
			case 'r': s++; x=TR; break;
			default:  x=T; break;
		}
		if(isdigit(*(s+1))) {s=gt_num(s+1,&n); s--;}
#ifndef KOSHER
		else n = 0;	/* NOT STANDARD FORTRAN, should be error */
#endif
#ifdef KOSHER
		fmtptr = s; return(FMTERR);
#endif
		op_gen(x,n,1,0,s);
		break;
	case 'x': op_gen(X,1,0,0,s); break;
	case 'p': op_gen(P,0,0,0,s); break;
#ifndef KOSHER
	case 'r': op_gen(R,10,1,0,s); break;  /*** NOT STANDARD FORTRAN ***/
#endif

	default: fmtptr = s; return(0);
	}
	s++;
	*p=s;
	return(FMTOK);
}

e_d(s,p) char *s,**p;
{	int n,w,d,e,x=0;
	char *sv=s;
	char c;
	s=gt_num(s,&n);
	op_gen(STACK,n,0,0,s);
	c = lcase(*s); s++;
	switch(c)
	{
	case 'd':
	case 'e':
	case 'g':
		s = gt_num(s, &w);
		if (w==0) break;
		if(*s=='.')
		{	s++;
			s=gt_num(s,&d);
		}
		else d=0;
		if(lcase(*s) == 'e'
#ifndef KOSHER
		|| *s == '.'		 /*** '.' is NOT STANDARD FORTRAN ***/
#endif
		)
		{	s++;
			s=gt_num(s,&e);
			if(c=='e') n=EE; else if(c=='d') n=DE; else n=GE;
		}
		else
		{	e=2;
			if(c=='e') n=E; else if(c=='d') n=D; else n=G;
		}
		op_gen(n,w,d,e,s);
		break;
	case 'l':
		s = gt_num(s, &w);
		if (w==0) break;
		op_gen(L,w,0,0,s);
		break;
	case 'a':
		skip(s);
		if(*s>='0' && *s<='9')
		{	s=gt_num(s,&w);
			if(w==0) break;
			op_gen(AW,w,0,0,s);
			break;
		}
		op_gen(A,0,0,0,s);
		break;
	case 'f':
		s = gt_num(s, &w);
		if (w==0) break;
		if(*s=='.')
		{	s++;
			s=gt_num(s,&d);
		}
		else d=0;
		op_gen(F,w,d,0,s);
		break;
	case 'i':
		s = gt_num(s, &w);
		if (w==0) break;
		if(*s =='.')
		{
			s++;
			s=gt_num(s,&d);
			x = IM;
		}
		else
		{	d = 1;
			x = I;
		}
		op_gen(x,w,d,0,s);
		break;
	default:
		pc--;	/* unSTACK */
		*p = sv;
		fmtptr = s;
		return(FMTERR);
	}
	*p = s;
	return(FMTOK);
}

op_gen(a,b,c,d,s) char *s;
{	struct syl *p= &syl[pc];
	if(pc>=SYLMX)
	{	fmtptr = s;
		fatal(F_ERFMT,"format too complex");
	}
#ifdef DEBUG
	fprintf(stderr,"%3d opgen: %d %d %d %d %c\n",
		pc,a,b,c,d,*s==GLITCH?'"':*s); /* for debug */
#endif
	p->op=a;
	p->p1=b;
	p->p2=c;
	p->p3=d;
	return(pc++);
}

char *gt_num(s,n) char *s; int *n;
{	int m=0,a_digit=NO;
	skip(s);
	while(isdigit(*s) || isspace(*s))
	{
		if (isdigit(*s))
		{
			m = 10*m + (*s)-'0';
			a_digit = YES;
		}
		s++;
	}
	if(a_digit) *n=m;
	else *n=1;
	return(s);
}

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