putscj.c

unix v7是最后一个广泛发布的研究型UNIX版本

/* INTERMEDIATE CODE GENERATION FOR S C JOHNSON C COMPILERS */
/* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
#if FAMILY != SCJ
	WRONG put FULE !!!!
#endif

#include "defs"
#include "scjdefs"

#define FOUR 4
extern int ops2[];
extern int types2[];

#define P2BUFFMAX 128
static long int p2buff[P2BUFFMAX];
static long int *p2bufp		= &p2buff[0];
static long int *p2bufend	= &p2buff[P2BUFFMAX];


puthead(s)
char *s;
{
char buff[100];
#if TARGET == VAX
	if(s)
		p2pass( sprintf(buff, "\t.globl\t_%s", s) );
#endif
/* put out fake copy of left bracket line, to be redone later */
if( ! headerdone )
	{
#if FAMILY==SCJ && OUTPUT==BINARY
	p2flush();
#endif
	headoffset = ftell(textfile);
	prhead(textfile);
	headerdone = YES;
	p2triple(P2STMT, (strlen(infname)+FOUR-1)/FOUR, 0);
	p2str(infname);
	}
}





/* It is necessary to precede each procedure with a "left bracket"
 * line that tells pass 2 how many register variables and how
 * much automatic space is required for the function.  This compiler
 * does not know how much automatic space is needed until the
 * entire procedure has been processed.  Therefore, "puthead"
 * is called at the begining to record the current location in textfile,
 * then to put out a placeholder left bracket line.  This procedure
 * repositions the file and rewrites that line, then puts the
 * file pointer back to the end of the file.
 */

putbracket()
{
long int hereoffset;

#if FAMILY==SCJ && OUTPUT==BINARY
	p2flush();
#endif
hereoffset = ftell(textfile);
if(fseek(textfile, headoffset, 0))
	fatal("fseek failed");
prhead(textfile);
if(fseek(textfile, hereoffset, 0))
	fatal("fseek failed 2");
}




putrbrack(k)
int k;
{
p2op(P2RBRACKET, k);
}



putnreg()
{
}






puteof()
{
p2op(P2EOF, 0);
p2flush();
}



putstmt()
{
p2triple(P2STMT, 0, lineno);
}




/* put out code for if( ! p) goto l  */
putif(p,l)
register expptr p;
int l;
{
register int k;

if( ( k = (p = fixtype(p))->vtype) != TYLOGICAL)
	{
	if(k != TYERROR)
		err("non-logical expression in IF statement");
	frexpr(p);
	}
else
	{
	putex1(p);
	p2icon( (long int) l , P2INT);
	p2op(P2CBRANCH, 0);
	putstmt();
	}
}





/* put out code for  goto l   */
putgoto(label)
int label;
{
p2triple(P2GOTO, 1, label);
putstmt();
}


/* branch to address constant or integer variable */
putbranch(p)
register struct addrblock *p;
{
putex1(p);
p2op(P2GOTO, P2INT);
putstmt();
}



/* put out label  l:     */
putlabel(label)
int label;
{
p2op(P2LABEL, label);
}




putexpr(p)
expptr p;
{
putex1(p);
putstmt();
}




putcmgo(index, nlab, labs)
expptr index;
int nlab;
struct labelblock *labs[];
{
int i, labarray, skiplabel;

if(! ISINT(index->vtype) )
	{
	execerr("computed goto index must be integer", NULL);
	return;
	}

#if TARGET == VAX
	/* use special case instruction */
	vaxgoto(index, nlab, labs);
#else
	labarray = newlabel();
	preven(ALIADDR);
	prlabel(asmfile, labarray);
	prcona(asmfile, (ftnint) (skiplabel = newlabel()) );
	for(i = 0 ; i < nlab ; ++i)
		prcona(asmfile, (ftnint)(labs[i]->labelno) );
	prcmgoto(index, nlab, skiplabel, labarray);
	putlabel(skiplabel);
#endif
}

putx(p)
expptr p;
{
struct addrblock *putcall(), *putcx1(), *realpart();
char *memname();
int opc;
int ncomma;
int type, k;

switch(p->tag)
	{
	case TERROR:
		free(p);
		break;

	case TCONST:
		switch(type = p->vtype)
			{
			case TYLOGICAL:
				type = tyint;
			case TYLONG:
			case TYSHORT:
				p2icon(p->const.ci, types2[type]);
				free(p);
				break;

			case TYADDR:
				p2triple(P2ICON, 1, P2INT|P2PTR);
				p2word(0L);
				p2name(memname(STGCONST, (int) p->const.ci) );
				free(p);
				break;

			default:
				putx( putconst(p) );
				break;
			}
		break;

	case TEXPR:
		switch(opc = p->opcode)
			{
			case OPCALL:
			case OPCCALL:
				if( ISCOMPLEX(p->vtype) )
					putcxop(p);
				else	putcall(p);
				break;

			case OPMIN:
			case OPMAX:
				putmnmx(p);
				break;


			case OPASSIGN:
				if( ISCOMPLEX(p->leftp->vtype) || ISCOMPLEX(p->rightp->vtype) )
					frexpr( putcxeq(p) );
				else if( ISCHAR(p) )
					putcheq(p);
				else
					goto putopp;
				break;

			case OPEQ:
			case OPNE:
				if( ISCOMPLEX(p->leftp->vtype) || ISCOMPLEX(p->rightp->vtype) )
					{
					putcxcmp(p);
					break;
					}
			case OPLT:
			case OPLE:
			case OPGT:
			case OPGE:
				if(ISCHAR(p->leftp))
					putchcmp(p);
				else
					goto putopp;
				break;

			case OPPOWER:
				putpower(p);
				break;

			case OPSTAR:
#if FAMILY == SCJ
				/*   m * (2**k) -> m<<k   */
				if(INT(p->leftp->vtype) && ISICON(p->rightp) &&
				   ( (k = log2(p->rightp->const.ci))>0) )
					{
					p->opcode = OPLSHIFT;
					frexpr(p->rightp);
					p->rightp = ICON(k);
					goto putopp;
					}
#endif

			case OPMOD:
				goto putopp;
			case OPPLUS:
			case OPMINUS:
			case OPSLASH:
			case OPNEG:
				if( ISCOMPLEX(p->vtype) )
					putcxop(p);
				else	goto putopp;
				break;

			case OPCONV:
				if( ISCOMPLEX(p->vtype) )
					putcxop(p);
				else if( ISCOMPLEX(p->leftp->vtype) )
					{
					ncomma = 0;
					putx( mkconv(p->vtype,
						realpart(putcx1(p->leftp, &ncomma))));
					putcomma(ncomma, p->vtype, NO);
					free(p);
					}
				else	goto putopp;
				break;

			case OPNOT:
			case OPOR:
			case OPAND:
			case OPEQV:
			case OPNEQV:
			case OPADDR:
			case OPPLUSEQ:
			case OPSTAREQ:
			case OPCOMMA:
			case OPQUEST:
			case OPCOLON:
			case OPBITOR:
			case OPBITAND:
			case OPBITXOR:
			case OPBITNOT:
			case OPLSHIFT:
			case OPRSHIFT:
		putopp:
				putop(p);
				break;

			default:
				fatal1("putx: invalid opcode %d", opc);
			}
		break;

	case TADDR:
		putaddr(p, YES);
		break;

	default:
		fatal1("putx: impossible tag %d", p->tag);
	}
}



LOCAL putop(p)
expptr p;
{
int k;
expptr lp, tp;
int pt, lt;
int comma;

switch(p->opcode)	/* check for special cases and rewrite */
	{
	case OPCONV:
		pt = p->vtype;
		lp = p->leftp;
		lt = lp->vtype;
		while(p->tag==TEXPR && p->opcode==OPCONV &&
		     ( (ISREAL(pt)&&ISREAL(lt)) ||
			(INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
			{
#if SZINT < SZLONG
			if(lp->tag != TEXPR)
				{
				if(pt==TYINT && lt==TYLONG)
					break;
				if(lt==TYINT && pt==TYLONG)
					break;
				}
#endif
			free(p);
			p = lp;
			pt = lt;
			lp = p->leftp;
			lt = lp->vtype;
			}
		if(p->tag==TEXPR && p->opcode==OPCONV)
			break;
		putx(p);
		return;

	case OPADDR:
		comma = NO;
		lp = p->leftp;
		if(lp->tag != TADDR)
			{
			tp = mktemp(lp->vtype, lp->vleng);
			putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
			lp = tp;
			comma = YES;
			}
		putaddr(lp, NO);
		if(comma)
			putcomma(1, TYINT, NO);
		free(p);
		return;
	}

if( (k = ops2[p->opcode]) <= 0)
	fatal1("putop: invalid opcode %d", p->opcode);
putx(p->leftp);
if(p->rightp)
	putx(p->rightp);
p2op(k, types2[p->vtype]);

if(p->vleng)
	frexpr(p->vleng);
free(p);
}

putforce(t, p)
int t;
expptr p;
{
p = mkconv(t, fixtype(p));
putx(p);
p2op(P2FORCE,
	(t==TYSHORT ? P2SHORT : (t==TYLONG ? P2LONG : P2DREAL)) );
putstmt();
}



LOCAL putpower(p)
expptr p;
{
expptr base;
struct addrblock *t1, *t2;
ftnint k;
int type;
int ncomma;

if(!ISICON(p->rightp) || (k = p->rightp->const.ci)<2)
	fatal("putpower: bad call");
base = p->leftp;
type = base->vtype;
t1 = mktemp(type, NULL);
t2 = NULL;
ncomma = 1;
putassign(cpexpr(t1), cpexpr(base) );

for( ; (k&1)==0 && k>2 ; k>>=1 )
	{
	++ncomma;
	putsteq(t1, t1);
	}

if(k == 2)
	putx( mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) );
else
	{
	t2 = mktemp(type, NULL);
	++ncomma;
	putassign(cpexpr(t2), cpexpr(t1));
	
	for(k>>=1 ; k>1 ; k>>=1)
		{
		++ncomma;
		putsteq(t1, t1);
		if(k & 1)
			{
			++ncomma;
			putsteq(t2, t1);
			}
		}
	putx( mkexpr(OPSTAR, cpexpr(t2),
		mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) ));
	}
putcomma(ncomma, type, NO);
frexpr(t1);
if(t2)
	frexpr(t2);
frexpr(p);
}




LOCAL struct addrblock *intdouble(p, ncommap)
struct addrblock *p;
int *ncommap;
{
register struct addrblock *t;

t = mktemp(TYDREAL, NULL);
++*ncommap;
putassign(cpexpr(t), p);
return(t);
}





LOCAL putcxeq(p)
register struct exprblock *p;
{
register struct addrblock *lp, *rp;
int ncomma;

ncomma = 0;
lp = putcx1(p->leftp, &ncomma);
rp = putcx1(p->rightp, &ncomma);
putassign(realpart(lp), realpart(rp));
if( ISCOMPLEX(p->vtype) )
	{
	++ncomma;
	putassign(imagpart(lp), imagpart(rp));
	}
putcomma(ncomma, TYREAL, NO);
frexpr(rp);
free(p);
return(lp);
}



LOCAL putcxop(p)
expptr p;
{
struct addrblock *putcx1();
int ncomma;

ncomma = 0;
putaddr( putcx1(p, &ncomma), NO);
putcomma(ncomma, TYINT, NO);
}



LOCAL struct addrblock *putcx1(p, ncommap)
register expptr p;
int *ncommap;
{
struct addrblock *q, *lp, *rp;
register struct addrblock *resp;
int opcode;
int ltype, rtype;

if(p == NULL)
	return(NULL);

switch(p->tag)
	{
	case TCONST:
		if( ISCOMPLEX(p->vtype) )
			p = putconst(p);
		return( p );

	case TADDR:
		if( ! addressable(p) )
			{
			++*ncommap;
			resp = mktemp(tyint, NULL);
			putassign( cpexpr(resp), p->memoffset );
			p->memoffset = resp;
			}
		return( p );

	case TEXPR:
		if( ISCOMPLEX(p->vtype) )
			break;
		++*ncommap;
		resp = mktemp(TYDREAL, NO);
		putassign( cpexpr(resp), p);
		return(resp);

	default:
		fatal1("putcx1: bad tag %d", p->tag);
	}

opcode = p->opcode;
if(opcode==OPCALL || opcode==OPCCALL)
	{
	++*ncommap;
	return( putcall(p) );
	}
else if(opcode == OPASSIGN)
	{
	++*ncommap;
	return( putcxeq(p) );
	}
resp = mktemp(p->vtype, NULL);
if(lp = putcx1(p->leftp, ncommap) )
	ltype = lp->vtype;
if(rp = putcx1(p->rightp, ncommap) )
	rtype = rp->vtype;

switch(opcode)
	{
	case OPCOMMA:
		frexpr(resp);
		resp = rp;
		rp = NULL;
		break;

	case OPNEG:
		putassign( realpart(resp), mkexpr(OPNEG, realpart(lp), NULL) );
		putassign( imagpart(resp), mkexpr(OPNEG, imagpart(lp), NULL) );
		*ncommap += 2;
		break;

	case OPPLUS:
	case OPMINUS:
		putassign( realpart(resp), mkexpr(opcode, realpart(lp), realpart(rp) ));
		if(rtype < TYCOMPLEX)
			putassign( imagpart(resp), imagpart(lp) );
		else if(ltype < TYCOMPLEX)
			{
			if(opcode == OPPLUS)
				putassign( imagpart(resp), imagpart(rp) );
			else	putassign( imagpart(resp), mkexpr(OPNEG, imagpart(rp), NULL) );
			}
		else
			putassign( imagpart(resp), mkexpr(opcode, imagpart(lp), imagpart(rp) ));

		*ncommap += 2;
		break;

	case OPSTAR:
		if(ltype < TYCOMPLEX)
			{
			if( ISINT(ltype) )
				lp = intdouble(lp, ncommap);
			putassign( realpart(resp), mkexpr(OPSTAR, cpexpr(lp), realpart(rp) ));
			putassign( imagpart(resp), mkexpr(OPSTAR, cpexpr(lp), imagpart(rp) ));
			}
		else if(rtype < TYCOMPLEX)
			{
			if( ISINT(rtype) )
				rp = intdouble(rp, ncommap);
			putassign( realpart(resp), mkexpr(OPSTAR, cpexpr(rp), realpart(lp) ));
			putassign( imagpart(resp), mkexpr(OPSTAR, cpexpr(rp), imagpart(lp) ));
			}
		else	{
			putassign( realpart(resp), mkexpr(OPMINUS,
				mkexpr(OPSTAR, realpart(lp), realpart(rp)),
				mkexpr(OPSTAR, imagpart(lp), imagpart(rp)) ));
			putassign( imagpart(resp), mkexpr(OPPLUS,
				mkexpr(OPSTAR, realpart(lp), imagpart(rp)),
				mkexpr(OPSTAR, imagpart(lp), realpart(rp)) ));
			}
		*ncommap += 2;
		break;

	case OPSLASH:
		/* fixexpr has already replaced all divisions
		 * by a complex by a function call
		 */
		if( ISINT(rtype) )
			rp = intdouble(rp, ncommap);
		putassign( realpart(resp), mkexpr(OPSLASH, realpart(lp), cpexpr(rp)) );
		putassign( imagpart(resp), mkexpr(OPSLASH, imagpart(lp), cpexpr(rp)) );
		*ncommap += 2;
		break;

	case OPCONV:
		putassign( realpart(resp), realpart(lp) );
		if( ISCOMPLEX(lp->vtype) )
			q = imagpart(lp);
		else if(rp != NULL)
			q = realpart(rp);
		else
			q = mkrealcon(TYDREAL, 0.0);
		putassign( imagpart(resp), q);
		*ncommap += 2;
		break;

	default:
		fatal1("putcx1 of invalid opcode %d", opcode);
	}

frexpr(lp);
frexpr(rp);
free(p);
return(resp);
}




LOCAL putcxcmp(p)
register struct exprblock *p;
{
int opcode;
int ncomma;
register struct addrblock *lp, *rp;
struct exprblock *q;

ncomma = 0;
opcode = p->opcode;
lp = putcx1(p->leftp, &ncomma);
rp = putcx1(p->rightp, &ncomma);