put.c

把fortran语言编的程序转为c语言编的程序, 运行环境linux

/****************************************************************
Copyright 1990, 1991, 1993, 1994 by AT&T Bell Laboratories and Bellcore.

Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.

AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness.  In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/

/*
 * INTERMEDIATE CODE GENERATION PROCEDURES COMMON TO BOTH
 * JOHNSON (PORTABLE) AND RITCHIE FAMILIES OF SECOND PASSES
*/

#include "defs.h"
#include "names.h"		/* For LOCAL_CONST_NAME */
#include "pccdefs.h"
#include "p1defs.h"

/* Definitions for   putconst()   */

#define LIT_CHAR 1
#define LIT_FLOAT 2
#define LIT_INT 3


/*
char *ops [ ] =
	{
	"??", "+", "-", "*", "/", "**", "-",
	"OR", "AND", "EQV", "NEQV", "NOT",
	"CONCAT",
	"<", "==", ">", "<=", "!=", ">=",
	" of ", " ofC ", " = ", " += ", " *= ", " CONV ", " << ", " % ",
	" , ", " ? ", " : "
	" abs ", " min ", " max ", " addr ", " indirect ",
	" bitor ", " bitand ", " bitxor ", " bitnot ", " >> ",
	};
*/

/* Each of these values is defined in   pccdefs   */

int ops2 [ ] =
{
	P2BAD, P2PLUS, P2MINUS, P2STAR, P2SLASH, P2BAD, P2NEG,
	P2OROR, P2ANDAND, P2EQ, P2NE, P2NOT,
	P2BAD,
	P2LT, P2EQ, P2GT, P2LE, P2NE, P2GE,
	P2CALL, P2CALL, P2ASSIGN, P2PLUSEQ, P2STAREQ, P2CONV, P2LSHIFT, P2MOD,
	P2COMOP, P2QUEST, P2COLON,
	1, P2BAD, P2BAD, P2BAD, P2BAD,
	P2BITOR, P2BITAND, P2BITXOR, P2BITNOT, P2RSHIFT,
	P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD,
	P2BAD, P2BAD, P2BAD, P2BAD,
	1,1,1,1,1, /* OPNEG1, OPDMIN, OPDMAX, OPASSIGNI, OPIDENTITY */
	1,1,1,1	/* OPCHARCAST, OPDABS, OPMIN2, OPMAX2 */
};


 void
#ifdef KR_headers
putexpr(p)
	expptr p;
#else
putexpr(expptr p)
#endif
{
/* Write the expression to the p1 file */

	p = (expptr) putx (fixtype (p));
	p1_expr (p);
}





 expptr
#ifdef KR_headers
putassign(lp, rp)
	expptr lp;
	expptr rp;
#else
putassign(expptr lp, expptr rp)
#endif
{
	return putx(fixexpr((Exprp)mkexpr(OPASSIGN, lp, rp)));
}




 void
#ifdef KR_headers
puteq(lp, rp)
	expptr lp;
	expptr rp;
#else
puteq(expptr lp, expptr rp)
#endif
{
	putexpr(mkexpr(OPASSIGN, lp, rp) );
}




/* put code for  a *= b */

 expptr
#ifdef KR_headers
putsteq(a, b)
	Addrp a;
	Addrp b;
#else
putsteq(Addrp a, Addrp b)
#endif
{
	return putx( fixexpr((Exprp)
		mkexpr(OPSTAREQ, cpexpr((expptr)a), cpexpr((expptr)b))));
}




 Addrp
#ifdef KR_headers
mkfield(res, f, ty)
	register Addrp res;
	char *f;
	int ty;
#else
mkfield(register Addrp res, char *f, int ty)
#endif
{
    res -> vtype = ty;
    res -> Field = f;
    return res;
} /* mkfield */


 Addrp
#ifdef KR_headers
realpart(p)
	register Addrp p;
#else
realpart(register Addrp p)
#endif
{
	register Addrp q;

	if (p->tag == TADDR
	 && p->uname_tag == UNAM_CONST
	 && ISCOMPLEX (p->vtype))
		return (Addrp)mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
			p->user.kludge.vstg1 ? p->user.Const.cds[0]
				: cds(dtos(p->user.Const.cd[0]),CNULL));

	q = (Addrp) cpexpr((expptr) p);
	if( ISCOMPLEX(p->vtype) )
		q = mkfield (q, "r", p -> vtype + TYREAL - TYCOMPLEX);

	return(q);
}




 expptr
#ifdef KR_headers
imagpart(p)
	register Addrp p;
#else
imagpart(register Addrp p)
#endif
{
	register Addrp q;

	if( ISCOMPLEX(p->vtype) )
	{
		if (p->tag == TADDR && p->uname_tag == UNAM_CONST)
			return mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
				p->user.kludge.vstg1 ? p->user.Const.cds[1]
				: cds(dtos(p->user.Const.cd[1]),CNULL));
		q = (Addrp) cpexpr((expptr) p);
		q = mkfield (q, "i", p -> vtype + TYREAL - TYCOMPLEX);
		return( (expptr) q );
	}
	else

/* Cast an integer type onto a Double Real type */

		return( mkrealcon( ISINT(p->vtype) ? TYDREAL : p->vtype , "0"));
}





/* ncat -- computes the number of adjacent concatenation operations */

 int
#ifdef KR_headers
ncat(p)
	register expptr p;
#else
ncat(register expptr p)
#endif
{
	if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
		return( ncat(p->exprblock.leftp) + ncat(p->exprblock.rightp) );
	else	return(1);
}




/* lencat -- returns the length of the concatenated string.  Each
   substring must have a static (i.e. compile-time) fixed length */

 ftnint
#ifdef KR_headers
lencat(p)
	register expptr p;
#else
lencat(register expptr p)
#endif
{
	if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
		return( lencat(p->exprblock.leftp) + lencat(p->exprblock.rightp) );
	else if( p->headblock.vleng!=NULL && ISICON(p->headblock.vleng) )
		return(p->headblock.vleng->constblock.Const.ci);
	else if(p->tag==TADDR && p->addrblock.varleng!=0)
		return(p->addrblock.varleng);
	else
	{
		err("impossible element in concatenation");
		return(0);
	}
}

/* putconst -- Creates a new Addrp value which maps onto the input
   constant value.  The Addrp doesn't retain the value of the constant,
   instead that value is copied into a table of constants (called
   litpool,   for pool of literal values).  The only way to retrieve the
   actual value of the constant is to look at the   memno   field of the
   Addrp result.  You know that the associated literal is the one referred
   to by   q   when   (q -> memno == litp -> litnum).
*/

 Addrp
#ifdef KR_headers
putconst(p)
	register Constp p;
#else
putconst(register Constp p)
#endif
{
	register Addrp q;
	struct Literal *litp, *lastlit;
	int k, len, type;
	int litflavor;
	double cd[2];
	ftnint nblanks;
	char *strp;
	char cdsbuf0[64], cdsbuf1[64], *ds[2];

	if (p->tag != TCONST)
		badtag("putconst", p->tag);

	q = ALLOC(Addrblock);
	q->tag = TADDR;
	type = p->vtype;
	q->vtype = ( type==TYADDR ? tyint : type );
	q->vleng = (expptr) cpexpr(p->vleng);
	q->vstg = STGCONST;

/* Create the new label for the constant.  This is wasteful of labels
   because when the constant value already exists in the literal pool,
   this label gets thrown away and is never reclaimed.  It might be
   cleaner to move this down past the first   switch()   statement below */

	q->memno = newlabel();
	q->memoffset = ICON(0);
	q -> uname_tag = UNAM_CONST;

/* Copy the constant info into the Addrblock; do this by copying the
   largest storage elts */

	q -> user.Const = p -> Const;
	q->user.kludge.vstg1 = p->vstg;	/* distinguish string from binary fp */

	/* check for value in literal pool, and update pool if necessary */

	k = 1;
	switch(type)
	{
	case TYCHAR:
		if (halign) {
			strp = p->Const.ccp;
			nblanks = p->Const.ccp1.blanks;
			len = p->vleng->constblock.Const.ci;
			litflavor = LIT_CHAR;
			goto loop;
			}
		else
			q->memno = BAD_MEMNO;
		break;
	case TYCOMPLEX:
	case TYDCOMPLEX:
		k = 2;
		if (p->vstg)
			cd[1] = atof(ds[1] = p->Const.cds[1]);
		else
			ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1);
	case TYREAL:
	case TYDREAL:
		litflavor = LIT_FLOAT;
		if (p->vstg)
			cd[0] = atof(ds[0] = p->Const.cds[0]);
		else
			ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0);
		goto loop;

	case TYLOGICAL1:
	case TYLOGICAL2:
	case TYLOGICAL:
	case TYLONG:
	case TYSHORT:
	case TYINT1:
#ifdef TYQUAD
	case TYQUAD:
#endif
 lit_int_flavor:
		litflavor = LIT_INT;

/* Scan the literal pool for this constant value.  If this same constant
   has been assigned before, use the same label.  Note that this routine
   does NOT consider two differently-typed constants with the same bit
   pattern to be the same constant */

 loop:
		lastlit = litpool + nliterals;
		for(litp = litpool ; litp<lastlit ; ++litp)

/* Remove this type checking to ensure that all bit patterns are reused */

			if(type == litp->littype) switch(litflavor)
			{
			case LIT_CHAR:
				if (len == (int)litp->litval.litival2[0]
				&& nblanks == litp->litval.litival2[1]
				&& !memcmp(strp, litp->cds[0], len)) {
					q->memno = litp->litnum;
					frexpr((expptr)p);
					q->user.Const.ccp1.ccp0 = litp->cds[0];
					return(q);
					}
				break;
			case LIT_FLOAT:
				if(cd[0] == litp->litval.litdval[0]
				&& !strcmp(ds[0], litp->cds[0])
				&& (k == 1 ||
				    cd[1] == litp->litval.litdval[1]
				    && !strcmp(ds[1], litp->cds[1]))) {
ret:
					q->memno = litp->litnum;
					frexpr((expptr)p);
					return(q);
					}
				break;

			case LIT_INT:
				if(p->Const.ci == litp->litval.litival)
					goto ret;
				break;
			}

/* If there's room in the literal pool, add this new value to the pool */

		if(nliterals < maxliterals)
		{
			++nliterals;

			/* litp   now points to the next free elt */

			litp->littype = type;
			litp->litnum = q->memno;
			switch(litflavor)
			{
			case LIT_CHAR:
				litp->litval.litival2[0] = len;
				litp->litval.litival2[1] = nblanks;
				q->user.Const.ccp = litp->cds[0] =
					memcpy(gmem(len,0), strp, len);
				break;

			case LIT_FLOAT:
				litp->litval.litdval[0] = cd[0];
				litp->cds[0] = copys(ds[0]);
				if (k == 2) {
					litp->litval.litdval[1] = cd[1];
					litp->cds[1] = copys(ds[1]);
					}
				break;

			case LIT_INT:
				litp->litval.litival = p->Const.ci;
				break;
			} /* switch (litflavor) */
		}
		else
			many("literal constants", 'L', maxliterals);

		break;
	case TYADDR:
	    break;
	default:
		badtype ("putconst", p -> vtype);
		break;
	} /* switch */

	if (type != TYCHAR || halign)
	    frexpr((expptr)p);
	return( q );
}