/*	$Id: putscj.c,v 1.18 2008/12/19 08:08:48 ragge Exp $	*/
/*
 * Copyright(C) Caldera International Inc. 2001-2002. All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 *
 * Redistributions of source code and documentation must retain the above
 * copyright notice, this list of conditions and the following disclaimer.
 * Redistributions in binary form must reproduce the above copyright
 * notice, this list of conditions and the following disclaimer in the
 * documentation and/or other materials provided with the distribution.
 * All advertising materials mentioning features or use of this software
 * must display the following acknowledgement:
 * 	This product includes software developed or owned by Caldera
 *	International, Inc.
 * Neither the name of Caldera International, Inc. nor the names of other
 * contributors may be used to endorse or promote products derived from
 * this software without specific prior written permission.
 *
 * USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA
 * INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR
 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
 * DISCLAIMED.  IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE
 * FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 * HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT,
 * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
 * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 
 * POSSIBILITY OF SUCH DAMAGE.
 */
/* INTERMEDIATE CODE GENERATION FOR S C JOHNSON C COMPILERS */
/* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */

#include <unistd.h>
#include <string.h>

#include "defines.h"
#include "defs.h"

#include "scjdefs.h"

LOCAL struct bigblock *putcall(struct bigblock *p);
LOCAL NODE *putmnmx(struct bigblock *p);
LOCAL NODE *putmem(bigptr, int, ftnint);
LOCAL NODE *putaddr(struct bigblock *, int);
LOCAL void putct1(bigptr, struct bigblock *, struct bigblock *, int *);
LOCAL int ncat(bigptr p);
LOCAL NODE *putcat(struct bigblock *, bigptr);
LOCAL NODE *putchcmp(struct bigblock *p);
LOCAL NODE *putcheq(struct bigblock *p);
LOCAL NODE *putcxcmp(struct bigblock *p);
LOCAL struct bigblock *putcx1(bigptr);
LOCAL NODE *putcxop(bigptr p);
LOCAL struct bigblock *putcxeq(struct bigblock *p);
LOCAL NODE *putpower(bigptr p);
LOCAL NODE *putop(bigptr p);
LOCAL NODE *putchop(bigptr p);
LOCAL struct bigblock *putch1(bigptr);
LOCAL struct bigblock *intdouble(struct bigblock *);

extern int ops2[];
extern int types2[];
static char *inproc;
static NODE *callval; /* to get return value right */
extern int negrel[];

#define XINT(z) 	ONEOF(z, MSKINT|MSKCHAR)
#define	P2TYPE(x)	(types2[(x)->vtype])
#define	P2OP(x)		(ops2[(x)->b_expr.opcode])

static void
sendp2(NODE *p)
{
	extern int thisline;

	p2tree(p);
	thisline = lineno;
	if (debugflag)
		fwalk(p, e2print, 0);
	pass2_compile(ipnode(p));
}

static NODE *
putassign(bigptr lp, bigptr rp)
{
	return putx(fixexpr(mkexpr(OPASSIGN, lp, rp)));
}


void
puthead(char *s)
{
	struct interpass_prolog *ipp = ckalloc(sizeof(struct interpass_prolog));
	int olbl, lbl1, lbl2;
	unsigned int i;

	if (s == NULL)
		return;
	if (inproc)
		fatal1("puthead %s in procedure", s);
	inproc = s;
	olbl = lastlabno;
	lbl1 = newlabel();
	lbl2 = newlabel();

	for (i = 0; i < NIPPREGS; i++)
		ipp->ipp_regs[i] = 0;	/* no regs used yet */
	ipp->ipp_autos = 0;		/* no autos used yet */
	ipp->ipp_name = copys(s);		/* function name */
	ipp->ipp_type = INT;		/* type not known yet? */
	ipp->ipp_vis = 1;		/* always visible */
	ipp->ip_tmpnum = 0; 		/* no temp nodes used in F77 yet */
	ipp->ip_lblnum = olbl;		/* # used labels so far */
	ipp->ipp_ip.ip_lbl = lbl1; 	/* first label, for optim */
	ipp->ipp_ip.type = IP_PROLOG;
	pass2_compile((struct interpass *)ipp);

}

/* 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.
 */

void
putbracket()
{
	struct interpass_prolog *ipp = ckalloc(sizeof(struct interpass_prolog));
	unsigned int i;

	if (inproc == 0)
		fatal1("puteof outside procedure");
	for (i = 0; i < NIPPREGS; i++)
		ipp->ipp_regs[i] = 0;
	ipp->ipp_autos = autoleng;
	ipp->ipp_name = copys(inproc);
	ipp->ipp_type = INT; /* XXX should set the correct type */
	ipp->ipp_vis = 1;
	ipp->ip_tmpnum = 0;
	ipp->ip_lblnum = lastlabno;
	ipp->ipp_ip.ip_lbl = retlabel;
	ipp->ipp_ip.type = IP_EPILOG;
	printf("\t.text\n"); /* XXX */
	pass2_compile((struct interpass *)ipp);
	inproc = 0;
}



void
putrbrack(int k)
{
}


void
puteof()
{
}


/* put out code for if( ! p) goto l  */
void
putif(bigptr p, int l)
{
	NODE *p1;
	int k;

	if( ( k = (p = fixtype(p))->vtype) != TYLOGICAL) {
		if(k != TYERROR)
			err("non-logical expression in IF statement");
		frexpr(p);
	} else {
		p1 = putex1(p);
		if (p1->n_op == EQ && p1->n_right->n_op == ICON &&
		    p1->n_right->n_lval == 0 && logop(p1->n_left->n_op)) {
			/* created by OPOR */
			NODE *q = p1->n_left;
			q->n_op = negrel[q->n_op - EQ];
			nfree(p1->n_right);
			nfree(p1);
			p1 = q;
		}
		if (logop(p1->n_op) == 0)
			p1 = mkbinode(NE, p1, mklnode(ICON, 0, 0, INT), INT);
		if (p1->n_left->n_op == ICON) {
			/* change constants to right */
			NODE *p2 = p1->n_left;
			p1->n_left = p1->n_right;
			p1->n_right = p2;
			if (p1->n_op != EQ && p1->n_op != NE)
				p1->n_op = negrel[p1->n_op - EQ];
		}
		p1->n_op = negrel[p1->n_op - EQ];
		p1 = mkbinode(CBRANCH, p1, mklnode(ICON, l, 0, INT), INT);
		sendp2(p1);
	}
}

/* Arithmetic IF  */
void
prarif(bigptr p, int neg, int zer, int pos)
{
	bigptr x1 = fmktemp(p->vtype, NULL);

	putexpr(mkexpr(OPASSIGN, cpexpr(x1), p));
	putif(mkexpr(OPGE, cpexpr(x1), MKICON(0)), neg);
	putif(mkexpr(OPLE, x1, MKICON(0)), pos);
	putgoto(zer);
}

/* put out code for  goto l   */
void
putgoto(int label)
{
	NODE *p;

	p = mkunode(GOTO, mklnode(ICON, label, 0, INT), 0, INT);
	sendp2(p);
}


/* branch to address constant or integer variable */
void
putbranch(struct bigblock *q)
{
	NODE *p;

	p = mkunode(GOTO, putex1(q), 0, INT);
	sendp2(p);
}

/*
 * put out label l: in text segment
 */
void
putlabel(int label)
{
	struct interpass *ip = ckalloc(sizeof(struct interpass));

	ip->type = IP_DEFLAB;
	ip->lineno = lineno;
	ip->ip_lbl = label;
	pass2_compile(ip);
}


/*
 * Called from inner routines.  Generates a NODE tree and writes it out.
 */
void
putexpr(bigptr q)
{
	NODE *p;
	p = putex1(q);
	sendp2(p);
}



void
putcmgo(bigptr x, int nlab, struct labelblock *labels[])
{
	bigptr y;
	int i;

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

	y = fmktemp(x->vtype, NULL);
	putexpr(mkexpr(OPASSIGN, cpexpr(y), x));
#ifdef notyet /* target-specific computed goto */
	vaxgoto(y, nlab, labels);
#else
	/*
	 * Primitive implementation, should use table here.
	 */
	for(i = 0 ; i < nlab ; ++i)
		putif(mkexpr(OPNE, cpexpr(y), MKICON(i+1)), labels[i]->labelno);
	frexpr(y);
#endif
}

/*
 * Convert a f77 tree statement to something that looks like a
 * pcc expression tree.
 */
NODE *
putx(bigptr q)
{
	struct bigblock *x1;
	NODE *p = NULL; /* XXX */
	int opc;
	int type, k;

#ifdef PCC_DEBUG
	if (tflag) {
		printf("putx %p\n", q);
		fprint(q, 0);
	}
#endif

	switch(q->tag) {
	case TERROR:
		ckfree(q);
		break;

	case TCONST:
		switch(type = q->vtype) {
			case TYLOGICAL:
				type = tyint;
			case TYLONG:
			case TYSHORT:
				p = mklnode(ICON, q->b_const.fconst.ci,
				    0, types2[type]);
				ckfree(q);
				break;

			case TYADDR:
				p = mklnode(ICON, 0, 0, types2[type]);
				p->n_name = copys(memname(STGCONST,
				    (int)q->b_const.fconst.ci));
				ckfree(q);
				break;

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

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

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

			case OPASSIGN:
				if (ISCOMPLEX(q->b_expr.leftp->vtype) ||
				    ISCOMPLEX(q->b_expr.rightp->vtype)) {
					frexpr(putcxeq(q));
				} else if (ISCHAR(q))
					p = putcheq(q);
				else
					goto putopp;
				break;

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

			case OPPOWER:
				p = putpower(q);
				break;

			case OPSTAR:
				/*   m * (2**k) -> m<<k   */
				if (XINT(q->b_expr.leftp->vtype) &&
				    ISICON(q->b_expr.rightp) &&
				    ((k = flog2(q->b_expr.rightp->b_const.fconst.ci))>0) ) {
					q->b_expr.opcode = OPLSHIFT;
					frexpr(q->b_expr.rightp);
					q->b_expr.rightp = MKICON(k);
					goto putopp;
				}

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

			case OPCONV:
				if( ISCOMPLEX(q->vtype) )
					p = putcxop(q);
				else if (ISCOMPLEX(q->b_expr.leftp->vtype)) {
					p = putx(mkconv(q->vtype,
					    realpart(putcx1(q->b_expr.leftp))));
					ckfree(q);
				} else
					goto putopp;
				break;

			case OPAND:
				/* Create logical AND */
				x1 = fmktemp(TYLOGICAL, NULL);
				putexpr(mkexpr(OPASSIGN, cpexpr(x1),
				    mklogcon(0)));
				k = newlabel();
				putif(q->b_expr.leftp, k);
				putif(q->b_expr.rightp, k);
				putexpr(mkexpr(OPASSIGN, cpexpr(x1),
				    mklogcon(1)));
				putlabel(k);
				p = putx(x1);
				break;

			case OPNOT: /* Logical NOT */
				x1 = fmktemp(TYLOGICAL, NULL);
				putexpr(mkexpr(OPASSIGN, cpexpr(x1),
				    mklogcon(1)));
				k = newlabel();
				putif(q->b_expr.leftp, k);
				putexpr(mkexpr(OPASSIGN, cpexpr(x1),
				    mklogcon(0)));
				putlabel(k);
				p = putx(x1);
				break;

			case OPOR: /* Create logical OR */
				x1 = fmktemp(TYLOGICAL, NULL);
				putexpr(mkexpr(OPASSIGN, cpexpr(x1),
				    mklogcon(1)));
				k = newlabel();
				putif(mkexpr(OPEQ, q->b_expr.leftp,
				    mklogcon(0)), k);
				putif(mkexpr(OPEQ, q->b_expr.rightp,
				    mklogcon(0)), k);
				putexpr(mkexpr(OPASSIGN, cpexpr(x1),
				    mklogcon(0)));
				putlabel(k);
				p = putx(x1);
				break;

			case OPCOMMA:
				for (x1 = q; x1->b_expr.opcode == OPCOMMA; 
				    x1 = x1->b_expr.leftp)
					putexpr(x1->b_expr.rightp);
				p = putx(x1);
				break;

			case OPEQV:
			case OPNEQV:
			case OPADDR:
			case OPBITOR:
			case OPBITAND:
			case OPBITXOR:
			case OPBITNOT:
			case OPLSHIFT:
			case OPRSHIFT:
		putopp:
				p = putop(q);
				break;

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

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

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

LOCAL NODE *
putop(bigptr q)
{
	NODE *p;
	int k;
	bigptr lp, tp;
	int pt, lt;

#ifdef PCC_DEBUG
	if (tflag) {
		printf("putop %p\n", q);
		fprint(q, 0);
	}
#endif
	switch(q->b_expr.opcode) { /* check for special cases and rewrite */
	case OPCONV:
		pt = q->vtype;
		lp = q->b_expr.leftp;
		lt = lp->vtype;
		while(q->tag==TEXPR && q->b_expr.opcode==OPCONV &&
		     ((ISREAL(pt)&&ISREAL(lt)) ||
			(XINT(pt)&&(ONEOF(lt,MSKINT|MSKADDR))) )) {
			if(lp->tag != TEXPR) {
				if(pt==TYINT && lt==TYLONG)
					break;
				if(lt==TYINT && pt==TYLONG)
					break;
			}
			ckfree(q);
			q = lp;
			pt = lt;
			lp = q->b_expr.leftp;
			lt = lp->vtype;
		}
		if(q->tag==TEXPR && q->b_expr.opcode==OPCONV)
			break;
		p = putx(q);
		return p;

	case OPADDR:
		lp = q->b_expr.leftp;
		if(lp->tag != TADDR) {
			tp = fmktemp(lp->vtype, lp->vleng);
			p = putx(mkexpr(OPASSIGN, cpexpr(tp), lp));
			sendp2(p);
			lp = tp;
		}
		p = putaddr(lp, NO);
		ckfree(q);
		return p;
	}

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

	if(q->vleng)
		frexpr(q->vleng);
	ckfree(q);
	return p;
}

/*
 * Put return values into correct register.
 */
void
putforce(int t, bigptr p)
{
	NODE *p1;

	p = mkconv(t, fixtype(p));
	p1 = putx(p);
	p1 = mkunode(FORCE, p1, 0, 
		(t==TYSHORT ? SHORT : (t==TYLONG ? LONG : LDOUBLE)));
	sendp2(p1);
}

LOCAL NODE *
putpower(bigptr p)
{
	NODE *p3;
	bigptr base;
	struct bigblock *t1, *t2;
	ftnint k = 0; /* XXX gcc */
	int type;

	if(!ISICON(p->b_expr.rightp) ||
	    (k = p->b_expr.rightp->b_const.fconst.ci)<2)
		fatal("putpower: bad call");
	base = p->b_expr.leftp;
	type = base->vtype;
	t1 = fmktemp(type, NULL);
	t2 = NULL;
	p3 = putassign(cpexpr(t1), cpexpr(base) );
	sendp2(p3);

	for( ; (k&1)==0 && k>2 ; k>>=1 ) {
		p3 = putassign(cpexpr(t1),
		    mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)));
		sendp2(p3);
	}

	if(k == 2)
		p3 = putx(mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)));
	else {
		t2 = fmktemp(type, NULL);
		p3 = putassign(cpexpr(t2), cpexpr(t1));
		sendp2(p3);
	
		for(k>>=1 ; k>1 ; k>>=1) {
			p3 = putassign(cpexpr(t1),
			    mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)));
			sendp2(p3);
			if(k & 1) {
				p3 = putassign(cpexpr(t2),
				    mkexpr(OPSTAR, cpexpr(t2), cpexpr(t1)));
				sendp2(p3);
			}
		}
		p3 = putx( mkexpr(OPSTAR, cpexpr(t2),
		mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) ));
	}
	frexpr(t1);
	if(t2)
		frexpr(t2);
	frexpr(p);
	return p3;
}

LOCAL struct bigblock *
intdouble(struct bigblock *p)
{
	struct bigblock *t;

	t = fmktemp(TYDREAL, NULL);

	sendp2(putassign(cpexpr(t), p));
	return(t);
}

LOCAL struct bigblock *
putcxeq(struct bigblock *q)
{
	struct bigblock *lp, *rp;

	lp = putcx1(q->b_expr.leftp);
	rp = putcx1(q->b_expr.rightp);
	sendp2(putassign(realpart(lp), realpart(rp)));
	if( ISCOMPLEX(q->vtype) ) {
		sendp2(putassign(imagpart(lp), imagpart(rp)));
	}
	frexpr(rp);
	ckfree(q);
	return(lp);
}



LOCAL NODE *
putcxop(bigptr q)
{
	NODE *p;

	p = putaddr(putcx1(q), NO);
	return p;
}

LOCAL struct bigblock *
putcx1(bigptr qq)
{
	struct bigblock *q, *lp, *rp;
	register struct bigblock *resp;
	NODE *p;
	int opcode;
	int ltype, rtype;

	ltype = rtype = 0; /* XXX gcc */
	if(qq == NULL)
		return(NULL);

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

	case TADDR:
		if( ! addressable(qq) ) {
			resp = fmktemp(tyint, NULL);
			p = putassign( cpexpr(resp), qq->b_addr.memoffset );
			sendp2(p);
			qq->b_addr.memoffset = resp;
		}
		return( qq );

	case TEXPR:
		if( ISCOMPLEX(qq->vtype) )
			break;
		resp = fmktemp(TYDREAL, NO);
		p = putassign( cpexpr(resp), qq);
		sendp2(p);
		return(resp);

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

	opcode = qq->b_expr.opcode;
	if(opcode==OPCALL || opcode==OPCCALL) {
		q = putcall(qq);
		sendp2(callval);
		return(q);
	} else if(opcode == OPASSIGN) {
		return( putcxeq(qq) );
	}

	resp = fmktemp(qq->vtype, NULL);
	if((lp = putcx1(qq->b_expr.leftp) ))
		ltype = lp->vtype;
	if((rp = putcx1(qq->b_expr.rightp) ))
		rtype = rp->vtype;

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

	case OPNEG:
		p = putassign(realpart(resp),
		    mkexpr(OPNEG, realpart(lp), NULL));
		sendp2(p);
		p = putassign(imagpart(resp),
		    mkexpr(OPNEG, imagpart(lp), NULL));
		sendp2(p);
		break;

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

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

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

	case OPCONV:
		p = 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);
		sendp2(p);
		p = putassign( imagpart(resp), q);
		sendp2(p);
		break;

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

	frexpr(lp);
	frexpr(rp);
	ckfree(qq);
	return(resp);
}


LOCAL NODE *
putcxcmp(struct bigblock *p)
{
	NODE *p1;
	int opcode;
	struct bigblock *lp, *rp;
	struct bigblock *q;

	opcode = p->b_expr.opcode;
	lp = putcx1(p->b_expr.leftp);
	rp = putcx1(p->b_expr.rightp);

	q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
	    mkexpr(opcode, realpart(lp), realpart(rp)),
	    mkexpr(opcode, imagpart(lp), imagpart(rp)) );
	p1 = putx( fixexpr(q) );

	ckfree(lp);
	ckfree(rp);
	ckfree(p);
	return p1;
}

LOCAL struct bigblock *
putch1(bigptr p)
{
	struct bigblock *t;

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

	case TADDR:
		return(p);

	case TEXPR:
		switch(p->b_expr.opcode) {
			case OPCALL:
			case OPCCALL:
				t = putcall(p);
				sendp2(callval);
				break;

			case OPCONCAT:
				t = fmktemp(TYCHAR, cpexpr(p->vleng) );
				sendp2(putcat( cpexpr(t), p ));
				break;

			case OPCONV:
				if(!ISICON(p->vleng) ||
				    p->vleng->b_const.fconst.ci!=1
				   || ! XINT(p->b_expr.leftp->vtype) )
					fatal("putch1: bad character conversion");
				t = fmktemp(TYCHAR, MKICON(1) );
				sendp2(putassign( cpexpr(t), p));
				break;
			default:
				fatal1("putch1: invalid opcode %d", p->b_expr.opcode);
				t = NULL; /* XXX gcc */
			}
		return(t);

	default:
		fatal1("putch1: bad tag %d", p->tag);
	}
/* NOTREACHED */
return NULL; /* XXX gcc */
}




LOCAL NODE *
putchop(bigptr p)
{
	NODE *p1;

	p1 = putaddr( putch1(p) , NO );
	return p1;
}


/*
 * Assign a character to another.
 */
LOCAL NODE *
putcheq(struct bigblock *p)
{
	NODE *p1, *p2, *p3;

	if( p->b_expr.rightp->tag==TEXPR &&
	    p->b_expr.rightp->b_expr.opcode==OPCONCAT )
		p3 = putcat(p->b_expr.leftp, p->b_expr.rightp);
	else if( ISONE(p->b_expr.leftp->vleng) &&
	    ISONE(p->b_expr.rightp->vleng) ) {
		p1 = putaddr( putch1(p->b_expr.leftp) , YES );
		p2 = putaddr( putch1(p->b_expr.rightp) , YES );
		p3 = mkbinode(ASSIGN, p1, p2, CHAR);
	} else
		p3 = putx(call2(TYINT, "s_copy",
		    p->b_expr.leftp, p->b_expr.rightp));

	frexpr(p->vleng);
	ckfree(p);
	return p3;
}



/*
 * Compare character(s) code.
 */
LOCAL NODE *
putchcmp(struct bigblock *p)
{
	NODE *p1, *p2, *p3;

	if(ISONE(p->b_expr.leftp->vleng) && ISONE(p->b_expr.rightp->vleng) ) {
		p1 = putaddr( putch1(p->b_expr.leftp) , YES );
		p2 = putaddr( putch1(p->b_expr.rightp) , YES );
		p3 = mkbinode(ops2[p->b_expr.opcode], p1, p2, CHAR);
		ckfree(p);
	} else {
		p->b_expr.leftp = call2(TYINT,"s_cmp",
		    p->b_expr.leftp, p->b_expr.rightp);
		p->b_expr.rightp = MKICON(0);
		p3 = putop(p);
	}
	return p3;
}

LOCAL NODE *
putcat(bigptr lhs, bigptr rhs)
{
	NODE *p3;
	int n;
	struct bigblock *lp, *cp;

	n = ncat(rhs);
	lp = mktmpn(n, TYLENG, NULL);
	cp = mktmpn(n, TYADDR, NULL);

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

	p3 = putx( call4(TYSUBR, "s_cat", lhs, cp, lp, MKICON(n) ) );
	return p3;
}

LOCAL int
ncat(bigptr p)
{
	if(p->tag==TEXPR && p->b_expr.opcode==OPCONCAT)
		return( ncat(p->b_expr.leftp) + ncat(p->b_expr.rightp) );
	else
		return(1);
}

LOCAL void
putct1(bigptr q, bigptr lp, bigptr cp, int *ip)
{
	NODE *p;
	int i;
	struct bigblock *lp1, *cp1;

	if(q->tag==TEXPR && q->b_expr.opcode==OPCONCAT) {
		putct1(q->b_expr.leftp, lp, cp, ip);
		putct1(q->b_expr.rightp, lp, cp , ip);
		frexpr(q->vleng);
		ckfree(q);
	} else {
		i = (*ip)++;
		lp1 = cpexpr(lp);
		lp1->b_addr.memoffset =
		    mkexpr(OPPLUS, lp1->b_addr.memoffset, MKICON(i*FSZLENG));
		cp1 = cpexpr(cp);
		cp1->b_addr.memoffset =
		    mkexpr(OPPLUS, cp1->b_addr.memoffset, MKICON(i*FSZADDR));
		p = putassign( lp1, cpexpr(q->vleng) );
		sendp2(p);
		p = putassign( cp1, addrof(putch1(q)) );
		sendp2(p);
	}
}

/*
 * Create a tree that can later be converted to an OREG.
 */
static NODE *
oregtree(int off, int reg, int type)
{
	NODE *p, *q;

	p = mklnode(REG, 0, reg, INCREF(type));
	q = mklnode(ICON, off, 0, INT);
	return mkunode(UMUL, mkbinode(PLUS, p, q, INCREF(type)), 0, type);
}

static NODE *
putaddr(bigptr q, int indir)
{
	int type, type2, funct;
	NODE *p, *p1, *p2;
	ftnint offset;
	bigptr offp;

	p = p1 = p2 = NULL; /* XXX */

	type = q->vtype;
	type2 = types2[type];
	funct = (q->vclass==CLPROC ? FTN<<TSHIFT : 0);

	offp = (q->b_addr.memoffset ? cpexpr(q->b_addr.memoffset) : NULL);

	offset = simoffset(&offp);
	if(offp)
		offp = mkconv(TYINT, offp);

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

		if(!indir && !offp && !offset) {
			p = mklnode(REG, 0, AUTOREG, INCREF(type2));
			break;
		}

		p = mklnode(REG, 0, AUTOREG, INCREF(type2));
		if(offp) {
			p1 = putx(offp);
			if(offset)
				p2 = mklnode(ICON, offset, 0, INT);
		} else
			p1 = mklnode(ICON, offset, 0, INT);
		if (offp && offset)
			p1 = mkbinode(PLUS, p1, p2, INCREF(type2));
		p = mkbinode(PLUS, p, p1, INCREF(type2));
		if (indir)
			p = mkunode(UMUL, p, 0, type2);
		break;

	case STGARG:
		p = oregtree(ARGOFFSET + (ftnint)(q->b_addr.memno),
		    ARGREG, INCREF(type2)|funct);

		if (offp)
			p1 = putx(offp);
		if (offset)
			p2 = mklnode(ICON, offset, 0, INT);
		if (offp && offset)
			p1 = mkbinode(PLUS, p1, p2, INCREF(type2));
		else if (offset)
			p1 = p2;
		if (offp || offset)
			p = mkbinode(PLUS, p, p1, INCREF(type2));
		if (indir)
			p = mkunode(UMUL, p, 0, type2);
		break;

	case STGLENG:
		if(indir) {
			p = oregtree(ARGOFFSET + (ftnint)(q->b_addr.memno),
			    ARGREG, INCREF(type2)|funct);
		} else	{
			fatal1("faddrnode: STGLENG: fixme!");
#if 0
			p2op(P2PLUS, types2[TYLENG] | P2PTR );
			p2reg(ARGREG, types2[TYLENG] | P2PTR );
			p2icon( ARGOFFSET +
				(ftnint) (FUDGEOFFSET*p->b_addr.memno), P2INT);
#endif
		}
		break;


	case STGBSS:
	case STGINIT:
	case STGEXT:
	case STGCOMMON:
	case STGEQUIV:
	case STGCONST:
		if(offp) {
			p1 = putx(offp);
			p2 = putmem(q, ICON, offset);
			p = mkbinode(PLUS, p1, p2, INCREF(type2));
			if(indir)
				p = mkunode(UMUL, p, 0, type2);
		} else
			p = putmem(q, (indir ? NAME : ICON), offset);
		break;

	case STGREG:
		if(indir)
			p = mklnode(REG, 0, q->b_addr.memno, type2);
		else
			fatal("attempt to take address of a register");
		break;

	default:
		fatal1("putaddr: invalid vstg %d", q->vstg);
	}
	frexpr(q);
	return p;
}

NODE *
putmem(bigptr q, int class, ftnint offset)
{
	NODE *p;
	int type2;

	type2 = types2[q->vtype];
	if(q->vclass == CLPROC)
		type2 |= (FTN<<TSHIFT);
	if (class == ICON)
		type2 |= PTR;
	p = mklnode(class, offset, 0, type2);
	p->n_name = copys(memname(q->vstg, q->b_addr.memno));
	return p;
}



LOCAL struct bigblock *
putcall(struct bigblock *qq)
{
	chainp arglist, charsp, cp;
	int n, first;
	struct bigblock *t;
	struct bigblock *q;
	struct bigblock *fval;
	int type, type2, ctype, indir;
	NODE *lp, *p1, *p2;

	lp = p2 = NULL; /* XXX */

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

	if(qq->b_expr.rightp) {
		arglist = qq->b_expr.rightp->b_list.listp;
		ckfree(qq->b_expr.rightp);
	} else
		arglist = NULL;

	for(cp = arglist ; cp ; cp = cp->chain.nextp)
		if(indir) {
			++n;
		} else {
			q = cp->chain.datap;
			if(q->tag == TCONST)
				cp->chain.datap = q = putconst(q);
			if( ISCHAR(q) ) {
				charsp = hookup(charsp,
				    mkchain(cpexpr(q->vleng), 0) );
				n += 2;
			} else if(q->vclass == CLPROC) {
				charsp = hookup(charsp,
				    mkchain( MKICON(0) , 0));
				n += 2;
			} else
				n += 1;
		}

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

	ctype = (fval ? P2INT : type2);
	p1 = putaddr(qq->b_expr.leftp, NO);

	if(fval) {
		first = NO;
		lp = putaddr( cpexpr(fval), NO);
		if(type==TYCHAR)
			lp = mkbinode(CM, lp, putx(cpexpr(qq->vleng)), INT);
	}

	for(cp = arglist ; cp ; cp = cp->chain.nextp) {
		q = cp->chain.datap;
		if(q->tag==TADDR && (indir || q->vstg!=STGREG) )
			p2 = putaddr(q, indir && q->vtype!=TYCHAR);
		else if( ISCOMPLEX(q->vtype) )
			p2 = putcxop(q);
		else if (ISCHAR(q) ) {
			p2 = putchop(q);
		} else if( ! ISERROR(q) ) {
			if(indir)
				p2 = putx(q);
			else	{
				t = fmktemp(q->vtype, q->vleng);
				p2 = putassign( cpexpr(t), q );
				sendp2(p2);
				p2 = putaddr(t, NO);
			}
		}
		if(first) {
			first = NO;
			lp = p2;
		} else
			lp = mkbinode(CM, lp, p2, INT);
	}

	if(arglist)
		frchain(&arglist);
	for(cp = charsp ; cp ; cp = cp->chain.nextp) {
		p2 = putx( mkconv(TYLENG,cp->chain.datap) );
		lp = mkbinode(CM, lp, p2, INT);
	}
	frchain(&charsp);
	if (n > 0)
		callval = mkbinode(CALL, p1, lp, ctype);
	else
		callval = mkunode(UCALL, p1, 0, ctype);
	ckfree(qq);
	return(fval);
}

/*
 * Write out code to do min/max calculations.
 * Note that these operators may have multiple arguments in fortran.
 */
LOCAL NODE *
putmnmx(struct bigblock *p)
{
	NODE *n1, *n2;
	int op, type, lab;
	chainp p0, p1;
	struct bigblock *tp;

	type = p->vtype;
	op = (p->b_expr.opcode==OPMIN ? LT : GT );
	p0 = p->b_expr.leftp->b_list.listp;
	ckfree(p->b_expr.leftp);
	ckfree(p);

	/*
	 * Store first value in a temporary, then compare it with 
	 * each following value and save that if needed.
	 */
	tp = fmktemp(type, NULL);
	sendp2(putassign(cpexpr(tp), p0->chain.datap));

	for(p1 = p0->chain.nextp ; p1 ; p1 = p1->chain.nextp) {
		n1 = putx(cpexpr(tp));
		n2 = putx(cpexpr(p1->chain.datap));
		lab = newlabel();
		sendp2(mkbinode(CBRANCH, mkbinode(op, n1, n2, INT), 
		    mklnode(ICON, lab, 0, INT), INT));
		sendp2(putassign(cpexpr(tp), p1->chain.datap));
		putlabel(lab);
	}
	return putx(tp);
}

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

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

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

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

	if(p->tag==TEXPR && p->b_expr.opcode==OPPLUS &&
	    ISICON(p->b_expr.rightp)) {
		rp = p->b_expr.rightp;
		lp = p->b_expr.leftp;
		offset += rp->b_const.fconst.ci;
		frexpr(rp);
		ckfree(p);
		*p0 = lp;
	}

	if(p->tag == TCONST) {
		offset += p->b_const.fconst.ci;
		frexpr(p);
		*p0 = NULL;
	}

	return(offset);
}

/*
 * F77 uses ckalloc() (malloc) for NODEs.
 */
NODE *
talloc()
{
	NODE *p = ckalloc(sizeof(NODE));
	p->n_name = "";
	return p;
}

#ifdef PCC_DEBUG
static char *tagnam[] = {
 "NONE", "NAME", "CONST", "EXPR", "ADDR", "PRIM", "LIST", "IMPLDO", "ERROR",
};
static char *typnam[] = {
 "unknown", "addr", "short", "long", "real", "dreal", "complex", "dcomplex",
 "logical", "char", "subr", "error",
};
static char *classnam[] = {
 "unknown", "param", "var", "entry", "main", "block", "proc",
};
static char *stgnam[] = {
 "unknown", "arg", "auto", "bss", "init", "const", "intr", "stfunct",
 "common", "equiv", "reg", "leng",
};


/*
 * Print out a f77 tree, for diagnostic purposes.
 */
void
fprint(bigptr p, int indx)
{
	extern char *ops[];
	int x = indx;
	bigptr lp, rp;
	struct chain *bp;

	if (p == NULL)
		return;

	while (x >= 2) {
		putchar('\t');
		x -= 2;
	}
	if (x--)
		printf("    " );
	printf("%p) %s, ", p, tagnam[p->tag]);
	if (p->vtype)
		printf("type=%s, ", typnam[p->vtype]);
	if (p->vclass)
		printf("class=%s, ", classnam[p->vclass]);
	if (p->vstg)
		printf("stg=%s, ", stgnam[p->vstg]);

	lp = rp = NULL;
	switch (p->tag) {
	case TEXPR:
		printf("OP %s\n", ops[p->b_expr.opcode]);
		lp = p->b_expr.leftp;
		rp = p->b_expr.rightp;
		break;
	case TADDR:
		printf("memno=%d\n", p->b_addr.memno);
		lp = p->vleng;
		rp = p->b_addr.memoffset;
		break;
	case TCONST:
		switch (p->vtype) {
		case TYSHORT:
		case TYLONG:
		case TYLOGICAL:
		case TYADDR:
			printf("val=%ld\n", p->b_const.fconst.ci);
			break;
		case TYCHAR:
			lp = p->vleng;
			printf("\n");
			break;
		}
		break;
	case TPRIM:
		lp = p->b_prim.namep;
		rp = p->b_prim.argsp;
		printf("fcharp=%p, lcharp=%p\n", p->b_prim.fcharp, p->b_prim.lcharp);
		break;
	case TNAME:
		printf("name=%s\n", p->b_name.varname);
		break;
	case TLIST:
		printf("\n");
		for (bp = &p->b_list.listp->chain; bp; bp = &bp->nextp->chain)
			fprint(bp->datap, indx+1);
		break;
	default:
		printf("\n");
	}

	fprint(lp, indx+1);
	fprint(rp, indx+1);
}
#endif