4BSD/usr/src/cmd/f77/putpcc.c

Compare this file to the similar file:
Show the results in this format:

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

#include "defs"
#include "pccdefs"
Addrp putcall(), putcxeq(), putcx1(), realpart();
expptr imagpart();
ftnint lencat();

#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, class)
char *s;
int class;
{
char buff[100];
#if TARGET == VAX
	if(s)
		p2ps("\t.globl\t_%s", s);
#endif
/* put out fake copy of left bracket line, to be redone later */
if( ! headerdone )
	{
#if FAMILY == PCC
	p2flush();
#endif
	headoffset = ftell(textfile);
	prhead(textfile);
	headerdone = YES;
	p2triple(P2STMT, (strlen(infname)+FOUR-1)/FOUR, 0);
	p2str(infname);
#if TARGET == PDP11
	/* fake jump to start the optimizer */
	if(class != CLBLOCK)
		putgoto( fudgelabel = newlabel() );
#endif

#if TARGET == VAX
	/* jump from top to bottom */
	if(s!=CNULL && class!=CLBLOCK)
		{
		int proflab = newlabel();
		p2ps("_%s:", s);
		p2pi("\t.word\tLWM%d", procno);
		prsave(proflab);
		p2pi("\tjmp\tL%d", fudgelabel = newlabel());
		}
		
	}
}





/* 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 == PCC
	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))->headblock.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 Addrp 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->headblock.vtype) )
	{
	execerr("computed goto index must be integer", CNULL);
	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)
		if( labs[i] )
			prcona(asmfile, (ftnint)(labs[i]->labelno) );
	prcmgoto(index, nlab, skiplabel, labarray);
	putlabel(skiplabel);
#endif
}

putx(p)
expptr p;
{
char *memname();
int opc;
int ncomma;
int type, k;

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

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

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

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

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

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


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

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

			case OPPOWER:
				putpower(p);
				break;

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

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

			case OPCONV:
				if( ISCOMPLEX(p->exprblock.vtype) )
					putcxop(p);
				else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) )
					{
					ncomma = 0;
					putx( mkconv(p->exprblock.vtype,
						realpart(putcx1(p->exprblock.leftp,
							&ncomma))));
					putcomma(ncomma, p->exprblock.vtype, NO);
					free( (charptr) 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:
				badop("putx", opc);
			}
		break;

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

	default:
		badtag("putx", p->tag);
	}
}



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

switch(p->exprblock.opcode)	/* check for special cases and rewrite */
	{
	case OPCONV:
		pt = p->exprblock.vtype;
		lp = p->exprblock.leftp;
		lt = lp->headblock.vtype;
		while(p->tag==TEXPR && p->exprblock.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

#if TARGET == VAX
			if(pt==TYDREAL && lt==TYREAL)
				{
				if(lp->tag==TEXPR &&
				   lp->exprblock.opcode==OPCONV &&
				   lp->exprblock.leftp->headblock.vtype==TYDREAL)
					{
					putx(lp->exprblock.leftp);
					p2op(P2CONV, P2REAL);
					p2op(P2CONV, P2DREAL);
					free( (charptr) p );
					return;
					}
				else break;
				}
#endif

			if(lt==TYCHAR && lp->tag==TEXPR && 
			   lp->exprblock.opcode==OPCALL)
				{
				p->exprblock.leftp = (expptr) putcall(lp);
				putop(p);
				putcomma(1, pt, NO);
				free( (charptr) p );
				return;
				}
			free( (charptr) p );
			p = lp;
			pt = lt;
			lp = p->exprblock.leftp;
			lt = lp->headblock.vtype;
			}
		if(p->tag==TEXPR && p->exprblock.opcode==OPCONV)
			break;
		putx(p);
		return;

	case OPADDR:
		comma = NO;
		lp = p->exprblock.leftp;
		if(lp->tag != TADDR)
			{
			tp = (expptr)
				mktemp(lp->headblock.vtype,lp->headblock.vleng);
			putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
			lp = tp;
			comma = YES;
			}
		putaddr(lp, NO);
		if(comma)
			putcomma(1, TYINT, NO);
		free( (charptr) p );
		return;
#if TARGET == VAX
/* take advantage of a glitch in the code generator that does not check
   the type clash in an assignment or comparison of an integer zero and
   a floating left operand, and generates optimal code for the correct
   type.  (The PCC has no floating-constant node to encode this correctly.)
*/
	case OPASSIGN:
	case OPLT:
	case OPLE:
	case OPGT:
	case OPGE:
	case OPEQ:
	case OPNE:
		if(ISREAL(p->exprblock.leftp->headblock.vtype) &&
		   ISREAL(p->exprblock.rightp->headblock.vtype) &&
		   ISCONST(p->exprblock.rightp) &&
		   p->exprblock.rightp->constblock.const.cd[0]==0)
			{
			p->exprblock.rightp->constblock.vtype = TYINT;
			p->exprblock.rightp->constblock.const.ci = 0;
			}
#endif
	}

if( (k = ops2[p->exprblock.opcode]) <= 0)
	badop("putop", p->exprblock.opcode);
putx(p->exprblock.leftp);
if(p->exprblock.rightp)
	putx(p->exprblock.rightp);
p2op(k, types2[p->exprblock.vtype]);

if(p->exprblock.vleng)
	frexpr(p->exprblock.vleng);
free( (charptr) 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;
Addrp t1, t2;
ftnint k;
int type;
int ncomma;

if(!ISICON(p->exprblock.rightp) ||
    (k = p->exprblock.rightp->constblock.const.ci)<2)
	fatal("putpower: bad call");
base = p->exprblock.leftp;
type = base->headblock.vtype;
t1 = mktemp(type, PNULL);
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, PNULL);
	++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 Addrp intdouble(p, ncommap)
Addrp p;
int *ncommap;
{
register Addrp t;

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





LOCAL Addrp putcxeq(p)
register expptr p;
{
register Addrp lp, rp;
int ncomma;

if(p->tag != TEXPR)
	badtag("putcxeq", p->tag);

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



LOCAL putcxop(p)
expptr p;
{
Addrp putcx1();
int ncomma;

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



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

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

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

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

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

	default:
		badtag("putcx1", p->tag);
	}

opcode = p->exprblock.opcode;
if(opcode==OPCALL || opcode==OPCCALL)
	{
	++*ncommap;
	return( putcall(p) );
	}
else if(opcode == OPASSIGN)
	{
	++*ncommap;
	return( putcxeq(p) );
	}
resp = mktemp(p->exprblock.vtype, PNULL);
if(lp = putcx1(p->exprblock.leftp, ncommap) )
	ltype = lp->vtype;
if(rp = putcx1(p->exprblock.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), ENULL) );
		putassign( imagpart(resp), mkexpr(OPNEG, imagpart(lp), ENULL) );
		*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), ENULL) );
			}
		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 = (expptr) realpart(rp);
		else
			q = mkrealcon(TYDREAL, 0.0);
		putassign( imagpart(resp), q);
		*ncommap += 2;
		break;

	default:
		badop("putcx1", opcode);
	}

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




LOCAL putcxcmp(p)
register expptr p;
{
int opcode;
int ncomma;
register Addrp lp, rp;
expptr q;

if(p->tag != TEXPR)
	badtag("putcxcmp", p->tag);

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

q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
	mkexpr(opcode, realpart(lp), realpart(rp)),
	mkexpr(opcode, imagpart(lp), imagpart(rp)) );
putx( fixexpr(q) );
putcomma(ncomma, TYINT, NO);

free( (charptr) lp);
free( (charptr) rp);
free( (charptr) p );
}

LOCAL Addrp putch1(p, ncommap)
register expptr p;
int * ncommap;
{
register Addrp t;
Addrp mktemp();
Addrp putconst();

switch(p->tag)
	{
	case TCONST:
		return( putconst(p) );

	case TADDR:
		return( (Addrp) p );

	case TEXPR:
		++*ncommap;

		switch(p->exprblock.opcode)
			{
			expptr q;

			case OPCALL:
			case OPCCALL:
				t = putcall(p);
				break;

			case OPCONCAT:
				t = mktemp(TYCHAR, ICON(lencat(p)) );
				q = (expptr) cpexpr(p->headblock.vleng);
				putcat( cpexpr(t), p );
				/* put the correct length on the block */
				frexpr(t->vleng);
				t->vleng = q;

				break;

			case OPCONV:
				if(!ISICON(p->exprblock.vleng)
				   || p->exprblock.vleng->constblock.const.ci!=1
				   || ! INT(p->exprblock.leftp->headblock.vtype) )
					fatal("putch1: bad character conversion");
				t = mktemp(TYCHAR, ICON(1) );
				putop( mkexpr(OPASSIGN, cpexpr(t), p) );
				break;
			default:
				badop("putch1", p->exprblock.opcode);
			}
		return(t);

	default:
		badtag("putch1", p->tag);
	}
/* NOTREACHED */
}




LOCAL putchop(p)
expptr p;
{
int ncomma;

ncomma = 0;
putaddr( putch1(p, &ncomma) , NO );
putcomma(ncomma, TYCHAR, YES);
}




LOCAL putcheq(p)
register expptr p;
{
int ncomma;
expptr lp, rp;

if(p->tag != TEXPR)
	badtag("putcheq", p->tag);

ncomma = 0;
lp = p->exprblock.leftp;
rp = p->exprblock.rightp;
if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT )
	putcat(lp, rp);
else if( ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) )
	{
	putaddr( putch1(lp, &ncomma) , YES );
	putaddr( putch1(rp, &ncomma) , YES );
	putcomma(ncomma, TYINT, NO);
	p2op(P2ASSIGN, P2CHAR);
	}
else
	{
	putx( call2(TYINT, "s_copy", lp, rp) );
	putcomma(ncomma, TYINT, NO);
	}

frexpr(p->exprblock.vleng);
free( (charptr) p );
}




LOCAL putchcmp(p)
register expptr p;
{
int ncomma;
expptr lp, rp;

if(p->tag != TEXPR)
	badtag("putchcmp", p->tag);

ncomma = 0;
lp = p->exprblock.leftp;
rp = p->exprblock.rightp;

if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) )
	{
	putaddr( putch1(lp, &ncomma) , YES );
	putaddr( putch1(rp, &ncomma) , YES );
	p2op(ops2[p->exprblock.opcode], P2CHAR);
	free( (charptr) p );
	putcomma(ncomma, TYINT, NO);
	}
else
	{
	p->exprblock.leftp = call2(TYINT,"s_cmp", lp, rp);
	p->exprblock.rightp = ICON(0);
	putop(p);
	}
}





LOCAL putcat(lhs, rhs)
register Addrp lhs;
register expptr rhs;
{
int n, ncomma;
Addrp lp, cp;

ncomma = 0;
n = ncat(rhs);
lp = mktmpn(n, TYLENG, PNULL);
cp = mktmpn(n, TYADDR, PNULL);

n = 0;
putct1(rhs, lp, cp, &n, &ncomma);

putx( call4(TYSUBR, "s_cat", lhs, cp, lp, mkconv(TYLONG, ICON(n)) ) );
putcomma(ncomma, TYINT, NO);
}





LOCAL putct1(q, lp, cp, ip, ncommap)
register expptr q;
register Addrp lp, cp;
int *ip, *ncommap;
{
int i;
Addrp lp1, cp1;

if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT)
	{
	putct1(q->exprblock.leftp, lp, cp, ip, ncommap);
	putct1(q->exprblock.rightp, lp, cp , ip, ncommap);
	frexpr(q->exprblock.vleng);
	free( (charptr) q );
	}
else
	{
	i = (*ip)++;
	lp1 = (Addrp) cpexpr(lp);
	lp1->memoffset = mkexpr(OPPLUS,lp1->memoffset, ICON(i*SZLENG));
	cp1 = (Addrp) cpexpr(cp);
	cp1->memoffset = mkexpr(OPPLUS, cp1->memoffset, ICON(i*SZADDR));
	putassign( lp1, cpexpr(q->headblock.vleng) );
	putassign( cp1, addrof(putch1(q,ncommap)) );
	*ncommap += 2;
	}
}

LOCAL putaddr(p, indir)
register Addrp p;
int indir;
{
int type, type2, funct;
ftnint offset, simoffset();
expptr offp, shorten();

if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) )
	{
	frexpr(p);
	return;
	}

type = p->vtype;
type2 = types2[type];
funct = (p->vclass==CLPROC ? P2FUNCT<<2 : 0);

offp = (p->memoffset ? (expptr) cpexpr(p->memoffset) : (expptr)NULL );


#if (FUDGEOFFSET != 1)
if(offp)
	offp = mkexpr(OPSTAR, ICON(FUDGEOFFSET), offp);
#endif

offset = simoffset( &offp );
#if SZINT < SZLONG
	if(offp)
		if(shortsubs)
			offp = shorten(offp);
		else
			offp = mkconv(TYINT, offp);
#else
	if(offp)
		offp = mkconv(TYINT, offp);
#endif

switch(p->vstg)
	{
	case STGAUTO:
		if(indir && !offp)
			{
			p2oreg(offset, AUTOREG, type2);
			break;
			}

		if(!indir && !offp && !offset)
			{
			p2reg(AUTOREG, type2 | P2PTR);
			break;
			}

		p2reg(AUTOREG, type2 | P2PTR);
		if(offp)
			{
			putx(offp);
			if(offset)
				p2icon(offset, P2INT);
			}
		else
			p2icon(offset, P2INT);
		if(offp && offset)
			p2op(P2PLUS, type2 | P2PTR);
		p2op(P2PLUS, type2 | P2PTR);
		if(indir)
			p2op(P2INDIRECT, type2);
		break;

	case STGARG:
		p2oreg(
#ifdef ARGOFFSET
			ARGOFFSET +
#endif
			(ftnint) (FUDGEOFFSET*p->memno),
			ARGREG,   type2 | P2PTR | funct );

	based:
		if(offp)
			putx(offp);
		if(offset)
			{
			p2icon(offset, P2INT);
			p2op(P2PLUS, type2 | P2PTR);
			}
		if(offp)
			p2op(P2PLUS, type2 | P2PTR);
		if(indir)
			p2op(P2INDIRECT, type2);
		break;

	case STGLENG:
		if(indir)
			{
			p2oreg(
#ifdef ARGOFFSET
				ARGOFFSET +
#endif
				(ftnint) (FUDGEOFFSET*p->memno),
				ARGREG,   type2 );
			}
		else	{
			p2reg(ARGREG, type2 | P2PTR );
			p2icon(
#ifdef ARGOFFSET
				ARGOFFSET +
#endif
				(ftnint) (FUDGEOFFSET*p->memno), P2INT);
			p2op(P2PLUS, type2 | P2PTR );
			}
		break;


	case STGBSS:
	case STGINIT:
	case STGEXT:
	case STGCOMMON:
	case STGEQUIV:
	case STGCONST:
		if(offp)
			{
			putx(offp);
			putmem(p, P2ICON, offset);
			p2op(P2PLUS, type2 | P2PTR);
			if(indir)
				p2op(P2INDIRECT, type2);
			}
		else
			putmem(p, (indir ? P2NAME : P2ICON), offset);

		break;

	case STGREG:
		if(indir)
			p2reg(p->memno, type2);
		else
			fatal("attempt to take address of a register");
		break;

/* for possible future use -- register based arrays
	case STGPREG:
		if(indir && !offp)
			p2oreg(offset, p->memno, type2);
		else
			{
			p2reg(p->memno, type2 | P2PTR);
			goto based;
			}
		break;
*/

	default:
		badstg("putaddr", p->vstg);
	}
frexpr(p);
}




LOCAL putmem(p, class, offset)
expptr p;
int class;
ftnint offset;
{
int type2;
int funct;
char *name,  *memname();

funct = (p->headblock.vclass==CLPROC ? P2FUNCT<<2 : 0);
type2 = types2[p->headblock.vtype];
if(p->headblock.vclass == CLPROC)
	type2 |= (P2FUNCT<<2);
name = memname(p->addrblock.vstg, p->addrblock.memno);
if(class == P2ICON)
	{
	p2triple(P2ICON, name[0]!='\0', type2|P2PTR);
	p2word(offset);
	if(name[0])
		p2name(name);
	}
else
	{
	p2triple(P2NAME, offset!=0, type2);
	if(offset != 0)
		p2word(offset);
	p2name(name);
	}
}



LOCAL Addrp putcall(p)
register Exprp p;
{
chainp arglist, charsp, cp;
int n, first;
Addrp t;
register expptr q;
Addrp fval;
int type, type2, ctype, qtype, indir;

type2 = types2[type = p->vtype];
charsp = NULL;
indir =  (p->opcode == OPCCALL);
n = 0;
first = YES;

if(p->rightp)
	{
	arglist = p->rightp->listblock.listp;
	free( (charptr) (p->rightp) );
	}
else
	arglist = NULL;

for(cp = arglist ; cp ; cp = cp->nextp)
	if(indir)
		++n;
	else	{
		q = (expptr) (cp->datap);
		if( ISCONST(q) )
			{
			q = (expptr) putconst(q);
			cp->datap = (tagptr) q;
			}
		if( ISCHAR(q) && q->headblock.vclass!=CLPROC )
			{
			charsp = hookup(charsp,
					mkchain(cpexpr(q->headblock.vleng),
						CHNULL));
			n += 2;
			}
		else
			n += 1;
		}

if(type == TYCHAR)
	{
	if( ISICON(p->vleng) )
		{
		fval = mktemp(TYCHAR, p->vleng);
		n += 2;
		}
	else	{
		err("adjustable character function");
		return;
		}
	}
else if( ISCOMPLEX(type) )
	{
	fval = mktemp(type, PNULL);
	n += 1;
	}
else
	fval = NULL;

ctype = (fval ? P2INT : type2);
putaddr(p->leftp, NO);

if(fval)
	{
	first = NO;
	putaddr( cpexpr(fval), NO);
	if(type==TYCHAR)
		{
		putx( mkconv(TYLENG,p->vleng) );
		p2op(P2LISTOP, type2);
		}
	}

for(cp = arglist ; cp ; cp = cp->nextp)
	{
	q = (expptr) (cp->datap);
	if(q->tag==TADDR && (indir || q->addrblock.vstg!=STGREG) )
		putaddr(q, indir && q->addrblock.vtype!=TYCHAR);
	else if( ISCOMPLEX(q->headblock.vtype) )
		putcxop(q);
	else if (ISCHAR(q) )
		putchop(q);
	else if( ! ISERROR(q) )
		{
		if(indir)
			putx(q);
		else	{
			t = mktemp(qtype = q->headblock.vtype,
				q->headblock.vleng);
			putassign( cpexpr(t), q );
			putaddr(t, NO);
			putcomma(1, qtype, YES);
			}
		}
	if(first)
		first = NO;
	else
		p2op(P2LISTOP, type2);
	}

if(arglist)
	frchain(&arglist);
for(cp = charsp ; cp ; cp = cp->nextp)
	{
	putx( mkconv(TYLENG,cp->datap) );
	p2op(P2LISTOP, type2);
	}
frchain(&charsp);
p2op(n>0 ? P2CALL : P2CALL0 , ctype);
free( (charptr) p );
return(fval);
}



LOCAL putmnmx(p)
register expptr p;
{
int op, type;
int ncomma;
expptr qp;
chainp p0, p1;
Addrp sp, tp;

if(p->tag != TEXPR)
	badtag("putmnmx", p->tag);

type = p->exprblock.vtype;
op = (p->exprblock.opcode==OPMIN ? OPLT : OPGT );
p0 = p->exprblock.leftp->listblock.listp;
free( (charptr) (p->exprblock.leftp) );
free( (charptr) p );

sp = mktemp(type, PNULL);
tp = mktemp(type, PNULL);
qp = mkexpr(OPCOLON, cpexpr(tp), cpexpr(sp));
qp = mkexpr(OPQUEST, mkexpr(op, cpexpr(tp),cpexpr(sp)), qp);
qp = fixexpr(qp);

ncomma = 1;
putassign( cpexpr(sp), p0->datap );

for(p1 = p0->nextp ; p1 ; p1 = p1->nextp)
	{
	++ncomma;
	putassign( cpexpr(tp), p1->datap );
	if(p1->nextp)
		{
		++ncomma;
		putassign( cpexpr(sp), cpexpr(qp) );
		}
	else
		putx(qp);
	}

putcomma(ncomma, type, NO);
frtemp(sp);
frtemp(tp);
frchain( &p0 );
}




LOCAL putcomma(n, type, indir)
int n, type, indir;
{
type = types2[type];
if(indir)
	type |= P2PTR;
while(--n >= 0)
	p2op(P2COMOP, type);
}




ftnint simoffset(p0)
expptr *p0;
{
ftnint offset, prod;
register expptr p, lp, rp;

offset = 0;
p = *p0;
if(p == NULL)
	return(0);

if( ! ISINT(p->headblock.vtype) )
	return(0);

if(p->tag==TEXPR && p->exprblock.opcode==OPSTAR)
	{
	lp = p->exprblock.leftp;
	rp = p->exprblock.rightp;
	if(ISICON(rp) && lp->tag==TEXPR &&
	   lp->exprblock.opcode==OPPLUS && ISICON(lp->exprblock.rightp))
		{
		p->exprblock.opcode = OPPLUS;
		lp->exprblock.opcode = OPSTAR;
		prod = rp->constblock.const.ci *
			lp->exprblock.rightp->constblock.const.ci;
		lp->exprblock.rightp->constblock.const.ci = rp->constblock.const.ci;
		rp->constblock.const.ci = prod;
		}
	}

if(p->tag==TEXPR && p->exprblock.opcode==OPPLUS &&
    ISICON(p->exprblock.rightp))
	{
	rp = p->exprblock.rightp;
	lp = p->exprblock.leftp;
	offset += rp->constblock.const.ci;
	frexpr(rp);
	free( (charptr) p );
	*p0 = lp;
	}

if( ISCONST(p) )
	{
	offset += p->constblock.const.ci;
	frexpr(p);
	*p0 = NULL;
	}

return(offset);
}





p2op(op, type)
int op, type;
{
p2triple(op, 0, type);
}

p2icon(offset, type)
ftnint offset;
int type;
{
p2triple(P2ICON, 0, type);
p2word(offset);
}




p2oreg(offset, reg, type)
ftnint offset;
int reg, type;
{
p2triple(P2OREG, reg, type);
p2word(offset);
p2name("");
}




p2reg(reg, type)
int reg, type;
{
p2triple(P2REG, reg, type);
}



p2pi(s, i)
char *s;
int i;
{
char buff[100];
sprintf(buff, s, i);
p2pass(buff);
}



p2pij(s, i, j)
char *s;
int i, j;
{
char buff[100];
sprintf(buff, s, i, j);
p2pass(buff);
}




p2ps(s, t)
char *s, *t;
{
char buff[100];
sprintf(buff, s, t);
p2pass(buff);
}




p2pass(s)
char *s;
{
p2triple(P2PASS, (strlen(s) + FOUR-1)/FOUR, 0);
p2str(s);
}




p2str(s)
register char *s;
{
union { long int word; char str[FOUR]; } u;
register int i;

i = 0;
u.word = 0;
while(*s)
	{
	u.str[i++] = *s++;
	if(i == FOUR)
		{
		p2word(u.word);
		u.word = 0;
		i = 0;
		}
	}
if(i > 0)
	p2word(u.word);
}




p2triple(op, var, type)
int op, var, type;
{
register long word;
word = op | (var<<8);
word |= ( (long int) type) <<16;
p2word(word);
}





p2name(s)
register char *s;
{
register int i;

#ifdef UCBPASS2
	/* arbitrary length names, terminated by a null,
	   padded to a full word */

#	define WL   sizeof(long int)
	union { long int word; char str[WL]; } w;
	
	w.word = 0;
	i = 0;
	while(w.str[i++] = *s++)
		if(i == WL)
			{
			p2word(w.word);
			w.word = 0;
			i = 0;
			}
	if(i > 0)
		p2word(w.word);
#else
	/* standard intermediate, names are 8 characters long */

	union  { long int word[2];  char str[8]; } u;
	
	u.word[0] = u.word[1] = 0;
	for(i = 0 ; i<8 && *s ; ++i)
		u.str[i] = *s++;
	p2word(u.word[0]);
	p2word(u.word[1]);

#endif

}




p2word(w)
long int w;
{
*p2bufp++ = w;
if(p2bufp >= p2bufend)
	p2flush();
}



p2flush()
{
if(p2bufp > p2buff)
	write(fileno(textfile), p2buff, (p2bufp-p2buff)*sizeof(long int));
p2bufp = p2buff;
}