xref: /csrg-svn/usr.bin/f77/libI77/fmt.c (revision 47943)
1*47943Sbostic /*-
2*47943Sbostic  * Copyright (c) 1980 The Regents of the University of California.
3*47943Sbostic  * All rights reserved.
42508Sdlw  *
5*47943Sbostic  * %sccs.include.proprietary.c%
623075Skre  */
723075Skre 
8*47943Sbostic #ifndef lint
9*47943Sbostic static char sccsid[] = "@(#)fmt.c	5.4 (Berkeley) 04/12/91";
10*47943Sbostic #endif /* not lint */
11*47943Sbostic 
1223075Skre /*
132508Sdlw  * fortran format parser
142508Sdlw  */
152508Sdlw 
162508Sdlw #include "fio.h"
172591Sdlw #include "format.h"
182508Sdlw 
192508Sdlw #define isdigit(x)	(x>='0' && x<='9')
202508Sdlw #define isspace(s)	(s==' ')
212508Sdlw #define skip(s)		while(isspace(*s)) s++
222508Sdlw 
232508Sdlw #ifdef interdata
242508Sdlw #define SYLMX 300
252508Sdlw #endif
262508Sdlw 
272508Sdlw #ifdef pdp11
282508Sdlw #define SYLMX 300
292508Sdlw #endif
302508Sdlw 
312508Sdlw #ifdef vax
322508Sdlw #define SYLMX 300
332508Sdlw #endif
342508Sdlw 
3529908Smckusick #ifdef tahoe
3629908Smckusick #define SYLMX 300
3729908Smckusick #endif
3829908Smckusick 
3941870Sbostic #ifdef hp300
4041870Sbostic #define SYLMX 300
4141870Sbostic #endif
4241870Sbostic 
4320984Slibs LOCAL struct syl syl_vec[SYLMX];
4417967Slibs struct syl *syl_ptr;
4520984Slibs LOCAL int parenlvl,revloc;
4620984Slibs int low_case[256];
4717967Slibs short pc;
482508Sdlw char *f_s(), *f_list(), *i_tem(), *gt_num(), *ap_end();
4917967Slibs char *s_init;
502508Sdlw 
pars_f()5117967Slibs pars_f()
522508Sdlw {
5317967Slibs 	short *s_ptr;
5417967Slibs 	long  *l_ptr;
5517979Slibs 	int i;
5617967Slibs 
5717979Slibs 	/* first time, initialize low_case[] */
5817979Slibs 	if( low_case[1] == 0 ) {
5917979Slibs 	    for(i = 0; i<256; i++) low_case[i]=i;
6017979Slibs 	    for(i = 'A'; i<='Z'; i++) low_case[i]=i-'A'+'a';
6117979Slibs 	}
6217979Slibs 
632508Sdlw 	parenlvl=revloc=pc=0;
6417979Slibs 
6517967Slibs 	s_ptr = (short *) fmtbuf;
6617967Slibs 	if( *s_ptr == FMT_COMP ) {
6717967Slibs 		/* already compiled - copy value of pc */
6817967Slibs 		pc = *(s_ptr+1);
6917967Slibs 		/* get address of the format */
7017967Slibs 		l_ptr = (long *) fmtbuf;
7117967Slibs 		fmtbuf = s_init = (char *) *(l_ptr+1);
7217967Slibs 		/* point syl_ptr to the compiled format */
7317967Slibs 		syl_ptr = (struct syl *) (l_ptr + 2);
7417967Slibs 		return(OK);
7517967Slibs 	} else {
7617967Slibs 		syl_ptr = syl_vec;
7717967Slibs 		s_init = fmtbuf;
7817967Slibs 		return((f_s(fmtbuf,0)==FMTERR)? ERROR : OK);
7917967Slibs 	}
802508Sdlw }
812508Sdlw 
8220984Slibs LOCAL
f_s(s,curloc)832508Sdlw char *f_s(s,curloc) char *s;
842508Sdlw {
852508Sdlw 	skip(s);
862508Sdlw 	if(*s++!='(')
872508Sdlw 	{
882508Sdlw 		fmtptr = s;
892508Sdlw 		return(FMTERR);
902508Sdlw 	}
912508Sdlw 	if(parenlvl++ ==1) revloc=curloc;
922508Sdlw 	op_gen(RET,curloc,0,0,s);
932508Sdlw 	if((s=f_list(s))==FMTERR)
942508Sdlw 	{
952508Sdlw 		return(FMTERR);
962508Sdlw 	}
972508Sdlw 	skip(s);
982508Sdlw 	return(s);
992508Sdlw }
1002508Sdlw 
10120984Slibs LOCAL
f_list(s)1022508Sdlw char *f_list(s) char *s;
1032508Sdlw {
1042508Sdlw 	while (*s)
1052508Sdlw 	{	skip(s);
1062508Sdlw 		if((s=i_tem(s))==FMTERR) return(FMTERR);
1072508Sdlw 		skip(s);
1082508Sdlw 		if(*s==',') s++;
1092508Sdlw 		else if(*s==')')
1102508Sdlw 		{	if(--parenlvl==0)
1112508Sdlw 				op_gen(REVERT,revloc,0,0,s);
11216597Sralph 			else
11316597Sralph 				op_gen(GOTO,0,0,0,s);
1142508Sdlw 			return(++s);
1152508Sdlw 		}
1162508Sdlw 	}
1172508Sdlw 	fmtptr = s;
1182508Sdlw 	return(FMTERR);
1192508Sdlw }
1202508Sdlw 
12120984Slibs LOCAL
i_tem(s)1222508Sdlw char *i_tem(s) char *s;
1232508Sdlw {	char *t;
1242508Sdlw 	int n,curloc;
1252508Sdlw 	if(*s==')') return(s);
12616597Sralph 	if ((n=ne_d(s,&t))==FMTOK)
12716597Sralph 		return(t);
12816597Sralph 	else if (n==FMTERR)
12916597Sralph 		return(FMTERR);
13016597Sralph 	if ((n=e_d(s,&t))==FMTOK)
13116597Sralph 		return(t);
13216597Sralph 	else if (n==FMTERR)
13316597Sralph 		return(FMTERR);
1342508Sdlw 	s=gt_num(s,&n);
13516597Sralph 	if (n == 0) { fmtptr = s; return(FMTERR); }
1362508Sdlw 	curloc = op_gen(STACK,n,0,0,s);
1372508Sdlw 	return(f_s(s,curloc));
1382508Sdlw }
1392508Sdlw 
14020984Slibs LOCAL
ne_d(s,p)1412508Sdlw ne_d(s,p) char *s,**p;
1422508Sdlw {	int n,x,sign=0,pp1,pp2;
14317979Slibs 	switch(low_case[*s])
1442508Sdlw 	{
1452508Sdlw 	case ':': op_gen(COLON,(int)('\n'),0,0,s); break;
1462508Sdlw #ifndef KOSHER
1472508Sdlw 	case '$': op_gen(DOLAR,(int)('\0'),0,0,s); break;  /*** NOT STANDARD FORTRAN ***/
1482508Sdlw #endif
1492508Sdlw 	case 'b':
15017979Slibs 		switch(low_case[*(s+1)])
1512508Sdlw 		{
15217876Sdlw 			case 'n': s++; op_gen(BNZ,0,0,0,s); break;
15317876Sdlw 			case 'z': s++; op_gen(BNZ,1,0,0,s); break;
15417876Sdlw #ifndef KOSHER
15517876Sdlw 			default: op_gen(B,0,0,0,s); break;  /*** NOT STANDARD FORTRAN ***/
15617876Sdlw #else
15717876Sdlw 			default: fmtptr = s; return(FMTUNKN);
15817876Sdlw #endif
1592508Sdlw 		}
1602508Sdlw 		break;
1612508Sdlw 	case 's':
16217979Slibs 		switch(low_case[*(s+1)])
1632508Sdlw 		{
1642508Sdlw 			case 'p': s++; x=SP; pp1=1; pp2=1; break;
1652508Sdlw #ifndef KOSHER
1662508Sdlw 			case 'u': s++; x=SU; pp1=0; pp2=0; break;  /*** NOT STANDARD FORTRAN ***/
1672508Sdlw #endif
1682508Sdlw 			case 's': s++; x=SS; pp1=0; pp2=1; break;
1692508Sdlw 			default:  x=S; pp1=0; pp2=1; break;
1702508Sdlw 		}
1712508Sdlw 		op_gen(x,pp1,pp2,0,s);
1722508Sdlw 		break;
1732508Sdlw 	case '/': op_gen(SLASH,0,0,0,s); break;
17412231Sdlw 
17512231Sdlw 	case '-': sign=1;	/* OUTRAGEOUS CODING */
17612231Sdlw 	case '+': s++;		/* OUTRAGEOUS CODING */
1772508Sdlw 	case '0': case '1': case '2': case '3': case '4':
1782508Sdlw 	case '5': case '6': case '7': case '8': case '9':
1792508Sdlw 		s=gt_num(s,&n);
18017979Slibs 		switch(low_case[*s])
1812508Sdlw 		{
1822508Sdlw 		case 'p': if(sign) n= -n; op_gen(P,n,0,0,s); break;
1832508Sdlw #ifndef KOSHER
1842508Sdlw 		case 'r': if(n<=1)		/*** NOT STANDARD FORTRAN ***/
18516597Sralph 			{	fmtptr = --s; return(FMTERR); }
1862508Sdlw 			op_gen(R,n,0,0,s); break;
1872508Sdlw 		case 't': op_gen(T,0,n,0,s); break;	/* NOT STANDARD FORT */
1882508Sdlw #endif
1892508Sdlw 		case 'x': op_gen(X,n,0,0,s); break;
19017967Slibs 		case 'h': op_gen(H,n,(s+1)-s_init,0,s);
1912508Sdlw 			s+=n;
1922508Sdlw 			break;
19316597Sralph 		default: fmtptr = s; return(FMTUNKN);
1942508Sdlw 		}
1952508Sdlw 		break;
1962508Sdlw 	case GLITCH:
1972508Sdlw 	case '"':
19817967Slibs 	case '\'': op_gen(APOS,s-s_init,0,0,s);
1992508Sdlw 		*p = ap_end(s);
2002508Sdlw 		return(FMTOK);
2012508Sdlw 	case 't':
20217979Slibs 		switch(low_case[*(s+1)])
2032508Sdlw 		{
2042508Sdlw 			case 'l': s++; x=TL; break;
2052508Sdlw 			case 'r': s++; x=TR; break;
2062508Sdlw 			default:  x=T; break;
2072508Sdlw 		}
2082508Sdlw 		if(isdigit(*(s+1))) {s=gt_num(s+1,&n); s--;}
20916597Sralph #ifdef KOSHER
21016597Sralph 		else { fmtptr = s; return(FMTERR); }
21116597Sralph #else
2122508Sdlw 		else n = 0;	/* NOT STANDARD FORTRAN, should be error */
2132508Sdlw #endif
2142508Sdlw 		op_gen(x,n,1,0,s);
2152508Sdlw 		break;
2162508Sdlw 	case 'x': op_gen(X,1,0,0,s); break;
2172508Sdlw 	case 'p': op_gen(P,0,0,0,s); break;
2182508Sdlw #ifndef KOSHER
2192508Sdlw 	case 'r': op_gen(R,10,1,0,s); break;  /*** NOT STANDARD FORTRAN ***/
2202508Sdlw #endif
2212508Sdlw 
22216597Sralph 	default: fmtptr = s; return(FMTUNKN);
2232508Sdlw 	}
2242508Sdlw 	s++;
2252508Sdlw 	*p=s;
2262508Sdlw 	return(FMTOK);
2272508Sdlw }
2282508Sdlw 
22920984Slibs LOCAL
e_d(s,p)2302508Sdlw e_d(s,p) char *s,**p;
23117967Slibs {	int n,w,d,e,x=0, rep_count;
2322508Sdlw 	char *sv=s;
2332508Sdlw 	char c;
23417967Slibs 	s=gt_num(s,&rep_count);
23517967Slibs 	if (rep_count == 0) goto ed_err;
23617979Slibs 	c = low_case[*s]; s++;
2372508Sdlw 	switch(c)
2382508Sdlw 	{
2392508Sdlw 	case 'd':
2402508Sdlw 	case 'e':
2412508Sdlw 	case 'g':
2422508Sdlw 		s = gt_num(s, &w);
24316597Sralph 		if (w==0) goto ed_err;
2442508Sdlw 		if(*s=='.')
2452508Sdlw 		{	s++;
2462508Sdlw 			s=gt_num(s,&d);
2472508Sdlw 		}
2482508Sdlw 		else d=0;
24917979Slibs 		if(low_case[*s] == 'e'
2502508Sdlw #ifndef KOSHER
2512508Sdlw 		|| *s == '.'		 /*** '.' is NOT STANDARD FORTRAN ***/
2522508Sdlw #endif
2532508Sdlw 		)
2542508Sdlw 		{	s++;
2552508Sdlw 			s=gt_num(s,&e);
25617967Slibs 			if (e==0 || e>127 || d>127 ) goto ed_err;
2572508Sdlw 			if(c=='e') n=EE; else if(c=='d') n=DE; else n=GE;
25817967Slibs 			op_gen(n,w,d + (e<<8),rep_count,s);
2592508Sdlw 		}
2602508Sdlw 		else
26117967Slibs 		{
2622508Sdlw 			if(c=='e') n=E; else if(c=='d') n=D; else n=G;
26317967Slibs 			op_gen(n,w,d,rep_count,s);
2642508Sdlw 		}
2652508Sdlw 		break;
2662508Sdlw 	case 'l':
2672508Sdlw 		s = gt_num(s, &w);
26816597Sralph 		if (w==0) goto ed_err;
26917967Slibs 		op_gen(L,w,0,rep_count,s);
2702508Sdlw 		break;
2712508Sdlw 	case 'a':
2722508Sdlw 		skip(s);
27316597Sralph 		if(isdigit(*s))
2742508Sdlw 		{	s=gt_num(s,&w);
27516597Sralph #ifdef	KOSHER
27616597Sralph 			if (w==0) goto ed_err;
27716597Sralph #else
27817967Slibs 			if (w==0) op_gen(A,0,0,rep_count,s);
27916597Sralph 			else
28016597Sralph #endif
28117967Slibs 			op_gen(AW,w,0,rep_count,s);
2822508Sdlw 			break;
2832508Sdlw 		}
28417967Slibs 		op_gen(A,0,0,rep_count,s);
2852508Sdlw 		break;
2862508Sdlw 	case 'f':
2872508Sdlw 		s = gt_num(s, &w);
28816597Sralph 		if (w==0) goto ed_err;
2892508Sdlw 		if(*s=='.')
2902508Sdlw 		{	s++;
2912508Sdlw 			s=gt_num(s,&d);
2922508Sdlw 		}
2932508Sdlw 		else d=0;
29417967Slibs 		op_gen(F,w,d,rep_count,s);
2952508Sdlw 		break;
29616597Sralph #ifndef	KOSHER
29716597Sralph 	case 'o':	/*** octal format - NOT STANDARD FORTRAN ***/
29816597Sralph 	case 'z':	/*** hex   format - NOT STANDARD FORTRAN ***/
29916597Sralph #endif
3002508Sdlw 	case 'i':
3012508Sdlw 		s = gt_num(s, &w);
30216597Sralph 		if (w==0) goto ed_err;
3032508Sdlw 		if(*s =='.')
3042508Sdlw 		{
3052508Sdlw 			s++;
3062508Sdlw 			s=gt_num(s,&d);
3072508Sdlw 			x = IM;
3082508Sdlw 		}
3092508Sdlw 		else
3102508Sdlw 		{	d = 1;
3112508Sdlw 			x = I;
3122508Sdlw 		}
31316597Sralph #ifndef KOSHER
31416597Sralph 		if (c == 'o')
31517967Slibs 			op_gen(R,8,1,rep_count,s);
31616597Sralph 		else if (c == 'z')
31717967Slibs 			op_gen(R,16,1,rep_count,s);
31816597Sralph #endif
31917967Slibs 		op_gen(x,w,d,rep_count,s);
32016597Sralph #ifndef KOSHER
32116597Sralph 		if (c == 'o' || c == 'z')
32217967Slibs 			op_gen(R,10,1,rep_count,s);
32316597Sralph #endif
3242508Sdlw 		break;
3252508Sdlw 	default:
3262508Sdlw 		*p = sv;
3272508Sdlw 		fmtptr = s;
32816597Sralph 		return(FMTUNKN);
3292508Sdlw 	}
3302508Sdlw 	*p = s;
3312508Sdlw 	return(FMTOK);
33216597Sralph ed_err:
33316597Sralph 	fmtptr = --s;
33416597Sralph 	return(FMTERR);
3352508Sdlw }
3362508Sdlw 
33720984Slibs LOCAL
op_gen(a,b,c,rep,s)33817967Slibs op_gen(a,b,c,rep,s) char *s;
33917967Slibs {	struct syl *p= &syl_ptr[pc];
3402508Sdlw 	if(pc>=SYLMX)
3412508Sdlw 	{	fmtptr = s;
3422591Sdlw 		fatal(F_ERFMT,"format too complex");
3432508Sdlw 	}
34417967Slibs 	if( b>32767 || c>32767 || rep>32767 )
34517967Slibs 	{	fmtptr = s;
34617967Slibs 		fatal("field width or repeat count too large");
34717967Slibs 	}
3482508Sdlw #ifdef DEBUG
3492508Sdlw 	fprintf(stderr,"%3d opgen: %d %d %d %d %c\n",
35017967Slibs 		pc,a,b,c,rep,*s==GLITCH?'"':*s); /* for debug */
3512508Sdlw #endif
3522508Sdlw 	p->op=a;
3532508Sdlw 	p->p1=b;
3542508Sdlw 	p->p2=c;
35517967Slibs 	p->rpcnt=rep;
3562508Sdlw 	return(pc++);
3572508Sdlw }
3582508Sdlw 
35920984Slibs LOCAL
gt_num(s,n)3602508Sdlw char *gt_num(s,n) char *s; int *n;
3612508Sdlw {	int m=0,a_digit=NO;
3622508Sdlw 	skip(s);
3632508Sdlw 	while(isdigit(*s) || isspace(*s))
3642508Sdlw 	{
3652508Sdlw 		if (isdigit(*s))
3662508Sdlw 		{
3672508Sdlw 			m = 10*m + (*s)-'0';
3682508Sdlw 			a_digit = YES;
3692508Sdlw 		}
3702508Sdlw 		s++;
3712508Sdlw 	}
3722508Sdlw 	if(a_digit) *n=m;
3732508Sdlw 	else *n=1;
3742508Sdlw 	return(s);
3752508Sdlw }
3762508Sdlw 
37720984Slibs LOCAL
ap_end(s)3782508Sdlw char *ap_end(s) char *s;
3792508Sdlw {
3802508Sdlw 	char quote;
3812508Sdlw 	quote = *s++;
3822508Sdlw 	for(;*s;s++)
3832508Sdlw 	{
3842508Sdlw 		if(*s==quote && *++s!=quote) return(s);
3852508Sdlw 	}
3862508Sdlw 	fmtptr = s;
3872591Sdlw 	fatal(F_ERFMT,"bad string");
3882508Sdlw }
389