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

/*
 * Copyright (c) 1980 Regents of the University of California.
 * All rights reserved.  The Berkeley software License Agreement
 * specifies the terms and conditions for redistribution.
 */

#ifndef lint
static char sccsid[] = "@(#)fmt.c	5.1 (Berkeley) %G%";
#endif not lint

/*
 *
 * fortran format parser
 * corresponds to fmt.c in /usr/lib/libI77
 */

/* define ERROR, OK, GLITCH, NO, YES 
 * from /usr/src/usr.lib/libI77/fiodefs.h
 */

#define GLITCH '\2'	/* special quote for Stu, generated in f77pass1 */
#define ERROR	1
#define OK	0
#define YES	1
#define NO	0

/* define struct syl[] and lots of defines for format terms */
#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,revloc, low_case[256];
short pc;
char *f_s(), *f_list(), *i_tem(), *gt_num(), *ap_end();
char *s_init, *fmtptr;
int fmt_strings;		/* tells if have hollerith or string in format*/

pars_f(s) char *s;
{
	int i;

	/* first time, initialize low_case[] */
	if( low_case[1] == 0 ) {
	    for(i = 0; i<256; i++) low_case[i]=i;
	    for(i = 'A'; i<='Z'; i++) low_case[i]=i-'A'+'a';
	}

	fmt_strings = 0;
	parenlvl=revloc=pc=0;
	s_init = s;	/* save beginning location of format */
	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 ((n=ne_d(s,&t))==FMTOK)
		return(t);
	else if (n==FMTERR)
		return(FMTERR);
	if ((n=e_d(s,&t))==FMTOK)
		return(t);
	else if (n==FMTERR)
		return(FMTERR);
	s=gt_num(s,&n);
	if (n == 0) { fmtptr = s; return(FMTERR); }
	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(low_case[*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(low_case[*(s+1)])
		{
			case 'n': s++; op_gen(BNZ,0,0,0,s); break;
			case 'z': s++; op_gen(BNZ,1,0,0,s); break;
#ifndef KOSHER
			default: op_gen(B,0,0,0,s); break;  /*** NOT STANDARD FORTRAN ***/
#else
			default: fmtptr = s; return(FMTUNKN);
#endif
		}
		break;
	case 's':
		switch(low_case[*(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;	/* OUTRAGEOUS CODING */
	case '+': s++;		/* OUTRAGEOUS CODING */
	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(low_case[*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,(s+1)-s_init,0,s);
			s+=n;
			fmt_strings = 1;
			break;
		default: fmtptr = s; return(FMTUNKN);
		}
		break;
	case GLITCH:
	case '"':
	case '\'': op_gen(APOS,s-s_init,0,0,s);
		*p = ap_end(s);
		fmt_strings = 1;
		return(FMTOK);
	case 't':
		switch(low_case[*(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--;}
#ifdef KOSHER
		else { fmtptr = s; return(FMTERR); }
#else
		else n = 0;	/* NOT STANDARD FORTRAN, should be error */
#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(FMTUNKN);
	}
	s++;
	*p=s;
	return(FMTOK);
}

e_d(s,p) char *s,**p;
{	int n,w,d,e,x=0, rep_count;
	char *sv=s;
	char c;
	s=gt_num(s,&rep_count);
	if (rep_count == 0) goto ed_err;
	c = low_case[*s]; s++;
	switch(c)
	{
	case 'd':
	case 'e':
	case 'g':
		s = gt_num(s, &w);
		if (w==0) goto ed_err;
		if(*s=='.')
		{	s++;
			s=gt_num(s,&d);
		}
		else d=0;
		if(low_case[*s] == 'e'
#ifndef KOSHER
		|| *s == '.'		 /*** '.' is NOT STANDARD FORTRAN ***/
#endif
		)
		{	s++;
			s=gt_num(s,&e);
			if (e==0 || e>127 || d>127 ) goto ed_err;
			if(c=='e') n=EE; else if(c=='d') n=DE; else n=GE;
			op_gen(n,w,d + (e<<8),rep_count,s);
		}
		else
		{
			if(c=='e') n=E; else if(c=='d') n=D; else n=G;
			op_gen(n,w,d,rep_count,s);
		}
		break;
	case 'l':
		s = gt_num(s, &w);
		if (w==0) goto ed_err;
		op_gen(L,w,0,rep_count,s);
		break;
	case 'a':
		skip(s);
		if(isdigit(*s))
		{	s=gt_num(s,&w);
#ifdef	KOSHER
			if (w==0) goto ed_err;
#else
			if (w==0) op_gen(A,0,0,rep_count,s);
			else
#endif
			op_gen(AW,w,0,rep_count,s);
			break;
		}
		op_gen(A,0,0,rep_count,s);
		break;
	case 'f':
		s = gt_num(s, &w);
		if (w==0) goto ed_err;
		if(*s=='.')
		{	s++;
			s=gt_num(s,&d);
		}
		else d=0;
		op_gen(F,w,d,rep_count,s);
		break;
#ifndef	KOSHER
	case 'o':	/*** octal format - NOT STANDARD FORTRAN ***/
	case 'z':	/*** hex   format - NOT STANDARD FORTRAN ***/
#endif
	case 'i':
		s = gt_num(s, &w);
		if (w==0) goto ed_err;
		if(*s =='.')
		{
			s++;
			s=gt_num(s,&d);
			x = IM;
		}
		else
		{	d = 1;
			x = I;
		}
#ifndef KOSHER
		if (c == 'o')
			op_gen(R,8,1,rep_count,s);
		else if (c == 'z')
			op_gen(R,16,1,rep_count,s);
#endif
		op_gen(x,w,d,rep_count,s);
#ifndef KOSHER
		if (c == 'o' || c == 'z')
			op_gen(R,10,1,rep_count,s);
#endif
		break;
	default:
		*p = sv;
		fmtptr = s;
		return(FMTUNKN);
	}
	*p = s;
	return(FMTOK);
ed_err:
	fmtptr = --s;
	return(FMTERR);
}

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