putpcc.c

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

/****************************************************************
Copyright 1990 - 1995 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 FOR S. C. JOHNSON C COMPILERS */
/* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */

#include "defs.h"
#include "pccdefs.h"
#include "output.h"		/* for nice_printf */
#include "names.h"
#include "p1defs.h"

static Addrp intdouble Argdcl((Addrp));
static Addrp putcx1 Argdcl((tagptr));
static tagptr putaddr Argdcl((tagptr));
static tagptr putcall Argdcl((tagptr, Addrp*));
static tagptr putcat Argdcl((tagptr, tagptr));
static Addrp putch1 Argdcl((tagptr));
static tagptr putchcmp Argdcl((tagptr));
static tagptr putcheq Argdcl((tagptr));
static void putct1 Argdcl((tagptr, Addrp, Addrp, ptr));
static tagptr putcxcmp Argdcl((tagptr));
static Addrp putcxeq Argdcl((tagptr));
static tagptr putmnmx Argdcl((tagptr));
static tagptr putop Argdcl((tagptr));
static tagptr putpower Argdcl((tagptr));

#define FOUR 4
extern int ops2[];
extern int proc_argchanges, proc_protochanges;
extern int krparens;

#define P2BUFFMAX 128

/* Puthead -- output the header information about subroutines, functions
   and entry points */

 void
#ifdef KR_headers
puthead(s, class)
	char *s;
	int class;
#else
puthead(char *s, int class)
#endif
{
	if (headerdone == NO) {
		if (class == CLMAIN)
			s = "MAIN__";
		p1_head (class, s);
		headerdone = YES;
		}
}

 void
#ifdef KR_headers
putif(p, else_if_p)
	register expptr p;
	int else_if_p;
#else
putif(register expptr p, int else_if_p)
#endif
{
	register int k;
	int n;
	long where;

	if (else_if_p) {
		p1put(P1_ELSEIFSTART);
		where = ftell(pass1_file);
		}
	if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype )) )
	{
		if(k != TYERROR)
			err("non-logical expression in IF statement");
		}
	else {
		if (else_if_p) {
			if (ei_next >= ei_last)
				{
				k = ei_last - ei_first;
				n = k + 100;
				ei_next = mem(n,0);
				ei_last = ei_first + n;
				if (k)
					memcpy(ei_next, ei_first, k);
				ei_first =  ei_next;
				ei_next += k;
				ei_last = ei_first + n;
				}
			p = putx(p);
			if (*ei_next++ = ftell(pass1_file) > where) {
				p1_if(p);
				new_endif();
				}
			else
				p1_elif(p);
			}
		else {
			p = putx(p);
			p1_if(p);
			}
		}
	}

 void
#ifdef KR_headers
putout(p)
	expptr p;
#else
putout(expptr p)
#endif
{
	p1_expr (p);

/* Used to make temporaries in holdtemps available here, but they */
/* may be reused too soon (e.g. when multiple **'s are involved). */
}


 void
#ifdef KR_headers
putcmgo(index, nlab, labs)
	expptr index;
	int nlab;
	struct Labelblock **labs;
#else
putcmgo(expptr index, int nlab, struct Labelblock **labs)
#endif
{
	if(! ISINT(index->headblock.vtype) )
	{
		execerr("computed goto index must be integer", CNULL);
		return;
	}

	p1comp_goto (index, nlab, labs);
}

 static expptr
#ifdef KR_headers
krput(p)
	register expptr p;
#else
krput(register expptr p)
#endif
{
	register expptr e, e1;
	register unsigned op;
	int t = krparens == 2 ? TYDREAL : p->exprblock.vtype;

	op = p->exprblock.opcode;
	e = p->exprblock.leftp;
	if (e->tag == TEXPR && e->exprblock.opcode == op) {
		e1 = (expptr)mktmp(t, ENULL);
		putout(putassign(cpexpr(e1), e));
		p->exprblock.leftp = e1;
		}
	else
		p->exprblock.leftp = putx(e);

	e = p->exprblock.rightp;
	if (e->tag == TEXPR && e->exprblock.opcode == op) {
		e1 = (expptr)mktmp(t, ENULL);
		putout(putassign(cpexpr(e1), e));
		p->exprblock.rightp = e1;
		}
	else
		p->exprblock.rightp = putx(e);
	return p;
	}

 expptr
#ifdef KR_headers
putx(p)
	register expptr p;
#else
putx(register expptr p)
#endif
{
	int opc;
	int k;

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

	case TCONST:
		switch(p->constblock.vtype)
		{
		case TYLOGICAL1:
		case TYLOGICAL2:
		case TYLOGICAL:
#ifdef TYQUAD
		case TYQUAD:
#endif
		case TYLONG:
		case TYSHORT:
		case TYINT1:
			break;

		case TYADDR:
			break;
		case TYREAL:
		case TYDREAL:

/* Don't write it out to the p2 file, since you'd need to call putconst,
   which is just what we need to avoid in the translator */

			break;
		default:
			p = putx( (expptr)putconst((Constp)p) );
			break;
		}
		break;

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

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


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

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

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

		case OPSTAR:
			/*   m * (2**k) -> m<<k   */
			if(INT(p->exprblock.leftp->headblock.vtype) &&
			    ISICON(p->exprblock.rightp) &&
			    ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) )
			{
				p->exprblock.opcode = OPLSHIFT;
				frexpr(p->exprblock.rightp);
				p->exprblock.rightp = ICON(k);
				goto putopp;
			}
			if (krparens && ISREAL(p->exprblock.vtype))
				return krput(p);

		case OPMOD:
			goto putopp;
		case OPPLUS:
			if (krparens && ISREAL(p->exprblock.vtype))
				return krput(p);
		case OPMINUS:
		case OPSLASH:
		case OPNEG:
		case OPNEG1:
		case OPABS:
		case OPDABS:
			if( ISCOMPLEX(p->exprblock.vtype) )
				p = putcxop(p);
			else	goto putopp;
			break;

		case OPCONV:
			if( ISCOMPLEX(p->exprblock.vtype) )
				p = putcxop(p);
			else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) )
			{
				p = putx( mkconv(p->exprblock.vtype,
				    (expptr)realpart(putcx1(p->exprblock.leftp))));
			}
			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:
		case OPASSIGNI:
		case OPIDENTITY:
		case OPCHARCAST:
		case OPMIN2:
		case OPMAX2:
		case OPDMIN:
		case OPDMAX:
putopp:
			p = putop(p);
			break;

		case OPCONCAT:
			/* weird things like ichar(a//a) */
			p = (expptr)putch1(p);
			break;

		default:
			badop("putx", opc);
			p = errnode ();
		}
		break;

	case TADDR:
		p = putaddr(p);
		break;

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

	return p;
}



 LOCAL expptr
#ifdef KR_headers
putop(p)
	expptr p;
#else
putop(expptr p)
#endif
{
	expptr lp, tp;
	int pt, lt, lt1;
	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;

/* Simplify nested type casts */

		while(p->tag==TEXPR && p->exprblock.opcode==OPCONV &&
		    ( (ISREAL(pt)&&ONEOF(lt,MSKREAL|MSKCOMPLEX)) ||
		    (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
		{
			if(pt==TYDREAL && lt==TYREAL)
			{
				if(lp->tag==TEXPR
				&& lp->exprblock.opcode == OPCONV) {
				    lt1 = lp->exprblock.leftp->headblock.vtype;
				    if (lt1 == TYDREAL) {
					lp->exprblock.leftp =
						putx(lp->exprblock.leftp);
					return p;
					}
				    if (lt1 == TYDCOMPLEX) {
					lp->exprblock.leftp = putx(
						(expptr)realpart(
						putcx1(lp->exprblock.leftp)));
					return p;
					}
				    }
				break;
			}
			else if (ISREAL(pt) && ISCOMPLEX(lt)) {
				p->exprblock.leftp = putx(mkconv(pt,
					(expptr)realpart(
						putcx1(p->exprblock.leftp))));
				break;
				}
			if(lt==TYCHAR && lp->tag==TEXPR &&
			    lp->exprblock.opcode==OPCALL)
			{

/* May want to make a comma expression here instead.  I had one, but took
   it out for my convenience, not for the convenience of the end user */

				putout (putcall (lp, (Addrp *) &(p ->
				    exprblock.leftp)));
				return putop (p);
			}
			if (lt == TYCHAR) {
				p->exprblock.leftp = putx(p->exprblock.leftp);
				return p;
				}
			if (pt < lt && ONEOF(lt,MSKINT|MSKREAL))
				break;
			frexpr(p->exprblock.vleng);
			free( (charptr) p );
			p = lp;
			if (p->tag != TEXPR)
				goto retputx;
			pt = lt;
			lp = p->exprblock.leftp;
			lt = lp->headblock.vtype;
		} /* while */
		if(p->tag==TEXPR && p->exprblock.opcode==OPCONV)
			break;
 retputx:
		return putx(p);

	case OPADDR:
		comma = NO;
		lp = p->exprblock.leftp;
		free( (charptr) p );
		if(lp->tag != TADDR)
		{
			tp = (expptr)
			    mktmp(lp->headblock.vtype,lp->headblock.vleng);
			p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
			lp = tp;
			comma = YES;
		}
		if(comma)
			p = mkexpr(OPCOMMA, p, putaddr(lp));
		else
			p = (expptr)putaddr(lp);
		return p;

	case OPASSIGN:
	case OPASSIGNI:
	case OPLT:
	case OPLE:
	case OPGT:
	case OPGE:
	case OPEQ:
	case OPNE:
	    ;
	}

	if( ops2[p->exprblock.opcode] <= 0)
		badop("putop", p->exprblock.opcode);
	lp = p->exprblock.leftp = putx(p->exprblock.leftp);
	if (p -> exprblock.rightp) {
		tp = p->exprblock.rightp = putx(p->exprblock.rightp);
		if (ISCONST(tp) && ISCONST(lp))
			p = fold(p);
		}
	return p;
}

 LOCAL expptr
#ifdef KR_headers
putpower(p)
	expptr p;
#else
putpower(expptr p)
#endif
{
	expptr base;
	Addrp t1, t2;
	ftnint k;
	int type;
	char buf[80];			/* buffer for text of comment */

	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 = mktmp(type, ENULL);
	t2 = NULL;

	free ((charptr) p);
	p = putassign (cpexpr((expptr) t1), base);

	sprintf (buf, "Computing %ld%s power", k,
		k == 2 ? "nd" : k == 3 ? "rd" : "th");
	p1_comment (buf);

	for( ; (k&1)==0 && k>2 ; k>>=1 )
	{
		p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
	}

	if(k == 2) {

/* Write the power computation out immediately */
		putout (p);
		p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)));
	} else {
		t2 = mktmp(type, ENULL);
		p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2),
						cpexpr((expptr)t1)));

		for(k>>=1 ; k>1 ; k>>=1)
		{
			p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
			if(k & 1)
			{
				p = mkexpr (OPCOMMA, p, putsteq(t2, t1));
			}
		}
/* Write the power computation out immediately */
		putout (p);
		p = putx( mkexpr(OPSTAR, cpexpr((expptr)t2),
		    mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))));
	}
	frexpr((expptr)t1);
	if(t2)
		frexpr((expptr)t2);
	return p;
}




 LOCAL Addrp
#ifdef KR_headers
intdouble(p)
	Addrp p;
#else
intdouble(Addrp p)
#endif
{
	register Addrp t;

	t = mktmp(TYDREAL, ENULL);
	putout (putassign(cpexpr((expptr)t), (expptr)p));
	return(t);
}





/* Complex-type variable assignment */

 LOCAL Addrp
#ifdef KR_headers
putcxeq(p)
	register expptr p;
#else
putcxeq(register expptr p)
#endif
{
	register Addrp lp, rp;
	expptr code;

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

	lp = putcx1(p->exprblock.leftp);
	rp = putcx1(p->exprblock.rightp);
	code = putassign ( (expptr)realpart(lp), (expptr)realpart(rp));

	if( ISCOMPLEX(p->exprblock.vtype) )
	{
		code = mkexpr (OPCOMMA, code, putassign
			(imagpart(lp), imagpart(rp)));
	}
	putout (code);
	frexpr((expptr)rp);
	free ((charptr) p);
	return lp;
}



/* putcxop -- used to write out embedded calls to complex functions, and
   complex arguments to procedures */

 expptr
#ifdef KR_headers
putcxop(p)
	expptr p;
#else
putcxop(expptr p)
#endif
{
	return (expptr)putaddr((expptr)putcx1(p));
}

#define PAIR(x,y) mkexpr (OPCOMMA, (x), (y))

 LOCAL Addrp
#ifdef KR_headers
putcx1(p)
	register expptr p;
#else
putcx1(register expptr p)
#endif
{
	expptr q;
	Addrp lp, rp;
	register Addrp resp;
	int opcode;
	int ltype, rtype;
	long ts, tskludge;

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

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

	case TADDR:
		resp = &p->addrblock;
		if (addressable(p))
			return (Addrp) p;
		ts = tskludge = 0;
		if (q = resp->memoffset) {
			if (resp->uname_tag == UNAM_REF) {
				q = cpexpr((tagptr)resp);
				q->addrblock.vtype = tyint;
				q->addrblock.cmplx_sub = 1;