Interdata_v6/usr/source/ratfor/ratinc/r1.c

#include "r.h"

char	scrat[500];

int	brkptr	-1;
int	brkstk[10];
int	forptr	0;
int	forstk[10];

repcode() {
	outcont(0);
	yyval = genlab();
	outcont(yyval);
	brkstk[++brkptr] = yyval+1;
	genlab();
	genlab();
}

untils(p1) register int p1; {
	outnum(p1+1);
	outcode("\tif(.not.");
	balpar(scrat);
	outcode(scrat);
	outcode(")");
	outgoto(p1);
	outcont(p1+2);
	brkptr--;
}

ifcode(p1) register int p1; {
	outcode("\tif(.not.");
	balpar(scrat);
	outcode(scrat);
	outcode(")");
	outgoto(yyval=genlab()); genlab();
}

whilecode(p1) register int p1; {
	outcont(0);
	brkstk[++brkptr] = yyval = genlab(); genlab();
	outnum(yyval);
	outcode("\tif(.not.");
	balpar(scrat);
	outcode(scrat);
	outcode(")");
	outgoto(yyval+1);
}

whilestat(p1) register int p1; {
	outgoto(p1);
	outcont(p1+1);
	brkptr--;
}

balpar(bp)
	register char *bp;
{
	register int  i, c, lpar;
	extern int peek;
	while( (c=getc()) == ' ' || c == '\t' || c=='\n' );
	peek = c;
	if( c != '(' ){
		error("missing left paren");
		bp[0] = '\0';
		return(bp);
	}
	for( lpar=i=0; (bp[i++]=c=getc())!='\0'; ){
		if( c=='\'' || c=='"' )
			while( (bp[i++]=getc()) != c );
		if( i>=499 || c=='{' || c=='}' ){
			error("missing right parenthesis at %.20s", bp);
			break;
		}
		if( c=='(' )
			lpar++;
		else if( c==')' )
			lpar--;
		if( lpar == 0 )
			break;
	}
	bp[i] = '\0';
	return(bp);
}

int	labval	23000;

genlab(){
	return(++labval);
}

gokcode(p1) char *p1; {
	outcode("\t");
	outcode(p1);
	eatup(p1,scrat);
	outcode(scrat);
	outcode(0);
}

eatup(p1,bp)
	char *p1;
	register char *bp;
{
	extern int peek;
	register int i,c,lnb,lpar;
	lnb = '\n';
	while( c = *p1++ )
		if( c!=' ' )
			lnb = c;
	i = lpar = 0;
  more:
	for( ; (bp[i++]=c=getc())!=';' && c!='{' && c!='\n' && c!='}'; ){
		if( i>=499 ){
			error("statement too long at %.20s", bp);
			break;
		}
		if( c != ' ' && c != '\t' )
			lnb = c;
		if( c=='\'' || c=='"' )
			while( (bp[i++]=getc()) != c );
		if( c=='(' )
			lpar++;
		else if( c==')' ) {
			lpar--;
			if( lpar < 0 )
				error("missing left paren at %.20s",bp);
		}
	}
	if( c == '\n' ){
		if( lnb=='\n' || lnb=='+' || lnb=='-' || lnb=='*' || lnb=='('
			 || lnb==',' || lnb=='&'  || lnb=='|'
			|| lnb=='=' )
				goto more;
		c = ';';
	}
	if( c!=';' )
		peek = c;
	bp[i-1] = '\0';
	if( lpar > 0 )
		error("missing right paren at %.20s",bp);
	return(bp);
}

forcode(){
	extern int peek;
	register int i,j,c;
	register char *bp;
	char *alloc();
	outcont(0);
	balpar(scrat);
	yyval = genlab(); genlab(); genlab();
	brkstk[++brkptr] = yyval+1;
	if( scrat[0] == '\0' ){
		forstk[forptr++] = bp = alloc(1);
		*bp = '\0';
		return;
	}
	scrat[0] = '\t';
	for( i=1; (c=scrat[i++])!=';' && c!='\0' ; )
		if( c=='\'' || c=='"' )
			while( scrat[i++] != c );
	scrat[i-1] = '\0';
	if( nonblank(scrat) ){
		outcode(scrat);
		outcode(0);
	}
	for( j=i; (c=scrat[i++])!=';' && c!='\0' ; )
		if( c=='\'' || c=='"' )
			while( scrat[i++] != c );
	scrat[i-1] = '\0';
	if( nonblank(&scrat[j]) ){
		outnum(yyval);
		outcode("\tif(.not.(");
		outcode(&scrat[j]);
		outcode("))");
		outgoto(yyval+2);
	}
	else
		outcont(yyval);
	for( j=0; scrat[i+1]!='\0'; )
		scrat[j++] = scrat[i++];
	scrat[j] = '\0';
	forstk[forptr++] = bp = alloc(j+1);
	for(i=0; *bp++ = scrat[i++]; );
}

forstat(p1)
	register int p1;
{
	register char *bp, *q;
	register int i;
	bp = forstk[--forptr];
	outnum(p1+1);
	if( nonblank(bp) ){
		outcode("\t");
		outcode(bp);
		outcode(0);
	}
	outgoto(p1);
	outcont(p1+2);
	for( q=bp; *q++; );
	free(bp, q-bp);
	brkptr--;
}

docode(new,p1)
	register int new;
	register char *p1;
{
	outcode("\t");
	outcode(p1);
	eatup(p1,scrat);
	yyval = 0;
	if(new){
		yyval = genlab(); genlab();
		brkstk[++brkptr] = yyval;
		outnum(yyval);
	}
	outcode(scrat);
	outcode(0);
}

dostat(p1)
	register int p1;
{
	if( p1==0 )
		return;
	outcont(p1);
	outcont(p1+1);
	brkptr--;
}

breakcode(p1)
	register int p1;
{
	if(brkptr<0){
		error("illegal BREAK");
		return;
	}
	outgoto(brkstk[brkptr]+1);
}

nextcode(p1) register int p1; {
	if(brkptr<0){
		error("illegal NEXT");
		return;
	}
	outgoto(brkstk[brkptr]);
}

nonblank(s)
	register char *s;
{
	register int c;
	while( c = *s++ )
		if( c!=' ' && c!='\t' && c!='\n' )
			return(1);
	return(0);
}

error(s1, s2) register char *s1, *s2; {
	extern int linect[],ninclude,infile;
	printf("error at line %d, file %d: ",linect[ninclude],infile);
	printf(s1,s2);
	printf("\n");
	errorflag = 1;
}

errcode(p1)
	register char *p1;
{
	register int c;
	extern int yychar;
	extern int linect[],ninclude,infile;
	printf("\nsyntax error, line %d, file %d\n", linect[ninclude],infile);
	while( (c=getc()) != ';' && c != '}' && c != '\n' && c != '\0' );
	yychar = -1;
	errorflag = 1;
}