putpcc.c

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

				p->addrblock.skip_offset = 1;
				resp->user.name->vsubscrused = 1;
				resp->uname_tag = UNAM_NAME;
				tskludge = typesize[resp->vtype]
					* (resp->Field ? 2 : 1);
				}
			else if (resp->isarray
					&& resp->vtype != TYCHAR) {
				if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
					  && resp->uname_tag == UNAM_NAME)
					q = mkexpr(OPMINUS, q,
					  mkintcon(resp->user.name->voffset));
				ts = typesize[resp->vtype]
					* (resp->Field ? 2 : 1);
				q = resp->memoffset = mkexpr(OPSLASH, q,
								ICON(ts));
				}
			}
		resp = mktmp(tyint, ENULL);
		putout(putassign(cpexpr((expptr)resp), q));
		p->addrblock.memoffset = tskludge
			? mkexpr(OPSTAR, (expptr)resp, ICON(tskludge))
			: (expptr)resp;
		if (ts) {
			resp = &p->addrblock;
			q = mkexpr(OPSTAR, resp->memoffset, ICON(ts));
			if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
				&& resp->uname_tag == UNAM_NAME)
				q = mkexpr(OPPLUS, q,
				    mkintcon(resp->user.name->voffset));
			resp->memoffset = q;
			}
		return (Addrp) p;

	case TEXPR:
		if( ISCOMPLEX(p->exprblock.vtype) )
			break;
		resp = mktmp(p->exprblock.vtype, ENULL);
		/*first arg of above mktmp call was TYDREAL before 19950102 */
		putout (putassign( cpexpr((expptr)resp), p));
		return(resp);

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

	opcode = p->exprblock.opcode;
	if(opcode==OPCALL || opcode==OPCCALL)
	{
		Addrp t;
		p = putcall(p, &t);
		putout(p);
		return t;
	}
	else if(opcode == OPASSIGN)
	{
		return putcxeq (p);
	}

/* BUG  (inefficient)  Generates too many temporary variables */

	resp = mktmp(p->exprblock.vtype, ENULL);
	if(lp = putcx1(p->exprblock.leftp) )
		ltype = lp->vtype;
	if(rp = putcx1(p->exprblock.rightp) )
		rtype = rp->vtype;

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

	case OPNEG:
	case OPNEG1:
		putout (PAIR (
			putassign( (expptr)realpart(resp),
				mkexpr(OPNEG, (expptr)realpart(lp), ENULL)),
			putassign( imagpart(resp),
				mkexpr(OPNEG, imagpart(lp), ENULL))));
		break;

	case OPPLUS:
	case OPMINUS: { expptr r;
		r = putassign( (expptr)realpart(resp),
		    mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp) ));
		if(rtype < TYCOMPLEX)
			q = putassign( imagpart(resp), imagpart(lp) );
		else if(ltype < TYCOMPLEX)
		{
			if(opcode == OPPLUS)
				q = putassign( imagpart(resp), imagpart(rp) );
			else
				q = putassign( imagpart(resp),
				    mkexpr(OPNEG, imagpart(rp), ENULL) );
		}
		else
			q = putassign( imagpart(resp),
			    mkexpr(opcode, imagpart(lp), imagpart(rp) ));
		r = PAIR (r, q);
		putout (r);
		break;
	    } /* case OPPLUS, OPMINUS: */
	case OPSTAR:
		if(ltype < TYCOMPLEX)
		{
			if( ISINT(ltype) )
				lp = intdouble(lp);
			putout (PAIR (
				putassign( (expptr)realpart(resp),
				    mkexpr(OPSTAR, cpexpr((expptr)lp),
					(expptr)realpart(rp))),
				putassign( imagpart(resp),
				    mkexpr(OPSTAR, cpexpr((expptr)lp), imagpart(rp)))));
		}
		else if(rtype < TYCOMPLEX)
		{
			if( ISINT(rtype) )
				rp = intdouble(rp);
			putout (PAIR (
				putassign( (expptr)realpart(resp),
				    mkexpr(OPSTAR, cpexpr((expptr)rp),
					(expptr)realpart(lp))),
				putassign( imagpart(resp),
				    mkexpr(OPSTAR, cpexpr((expptr)rp), imagpart(lp)))));
		}
		else	{
			putout (PAIR (
				putassign( (expptr)realpart(resp), mkexpr(OPMINUS,
				    mkexpr(OPSTAR, (expptr)realpart(lp),
					(expptr)realpart(rp)),
				    mkexpr(OPSTAR, imagpart(lp), imagpart(rp)))),
				putassign( imagpart(resp), mkexpr(OPPLUS,
				    mkexpr(OPSTAR, (expptr)realpart(lp), imagpart(rp)),
				    mkexpr(OPSTAR, imagpart(lp),
					(expptr)realpart(rp))))));
		}
		break;

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

	case OPCONV:
		if( ISCOMPLEX(lp->vtype) )
			q = imagpart(lp);
		else if(rp != NULL)
			q = (expptr) realpart(rp);
		else
			q = mkrealcon(TYDREAL, "0");
		putout (PAIR (
			putassign( (expptr)realpart(resp), (expptr)realpart(lp)),
			putassign( imagpart(resp), q)));
		break;

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

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




/* Only .EQ. and .NE. may be performed on COMPLEX data, other relations
   are not defined */

 LOCAL expptr
#ifdef KR_headers
putcxcmp(p)
	register expptr p;
#else
putcxcmp(register expptr p)
#endif
{
	int opcode;
	register Addrp lp, rp;
	expptr q;

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

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

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

	free( (charptr) lp);
	free( (charptr) rp);
	free( (charptr) p );
	if (ISCONST(q))
		return q;
	return 	putx( fixexpr((Exprp)q) );
}

/* putch1 -- Forces constants into the literal pool, among other things */

 LOCAL Addrp
#ifdef KR_headers
putch1(p)
	register expptr p;
#else
putch1(register expptr p)
#endif
{
	Addrp t;
	expptr e;

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

	case TADDR:
		return( (Addrp) p );

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

		case OPCALL:
		case OPCCALL:

			p = putcall(p, &t);
			putout (p);
			break;

		case OPCONCAT:
			t = mktmp(TYCHAR, ICON(lencat(p)));
			q = (expptr) cpexpr(p->headblock.vleng);
			p = putcat( cpexpr((expptr)t), p );
			/* put the correct length on the block */
			frexpr(t->vleng);
			t->vleng = q;
			putout (p);
			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 = mktmp(TYCHAR, ICON(1));
			e = mkexpr(OPCONV, (expptr)t, ENULL);
			e->headblock.vtype = TYCHAR;
			p = putop( mkexpr(OPASSIGN, cpexpr(e), p));
			putout (p);
			break;
		default:
			badop("putch1", p->exprblock.opcode);
		}
		return(t);

	default:
		badtag("putch1", p->tag);
	}
	/* NOT REACHED */ return 0;
}


/* putchop -- Write out a character actual parameter; that is, this is
   part of a procedure invocation */

 Addrp
#ifdef KR_headers
putchop(p)
	expptr p;
#else
putchop(expptr p)
#endif
{
	p = putaddr((expptr)putch1(p));
	return (Addrp)p;
}




 LOCAL expptr
#ifdef KR_headers
putcheq(p)
	register expptr p;
#else
putcheq(register expptr p)
#endif
{
	expptr lp, rp;
	int nbad;

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

	lp = p->exprblock.leftp;
	rp = p->exprblock.rightp;
	frexpr(p->exprblock.vleng);
	free( (charptr) p );

/* If s = t // u, don't bother copying the result, write it directly into
   this buffer */

	nbad = badchleng(lp) + badchleng(rp);
	if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT )
		p = putcat(lp, rp);
	else if( !nbad
		&& ISONE(lp->headblock.vleng)
		&& ISONE(rp->headblock.vleng) ) {
		lp = mkexpr(OPCONV, lp, ENULL);
		rp = mkexpr(OPCONV, rp, ENULL);
		lp->headblock.vtype = rp->headblock.vtype = TYCHAR;
		p = putop(mkexpr(OPASSIGN, lp, rp));
		}
	else
		p = putx( call2(TYSUBR, "s_copy", lp, rp) );
	return p;
}




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

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

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

	if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) {
		lp = mkexpr(OPCONV, lp, ENULL);
		rp = mkexpr(OPCONV, rp, ENULL);
		lp->headblock.vtype = rp->headblock.vtype = TYCHAR;
		}
	else {
		lp = call2(TYINT,"s_cmp", lp, rp);
		rp = ICON(0);
		}
	p->exprblock.leftp = lp;
	p->exprblock.rightp = rp;
	p = putop(p);
	return p;
}





/* putcat -- Writes out a concatenation operation.  Two temporary arrays
   are allocated,   putct1()   is called to initialize them, and then a
   call to runtime library routine   s_cat()   is inserted.

	This routine generates code which will perform an  (nconc lhs rhs)
   at runtime.  The runtime funciton does not return a value, the routine
   that calls this   putcat   must remember the name of   lhs.
*/


 LOCAL expptr
#ifdef KR_headers
putcat(lhs0, rhs)
	expptr lhs0;
	register expptr rhs;
#else
putcat(expptr lhs0, register expptr rhs)
#endif
{
	register Addrp lhs = (Addrp)lhs0;
	int n, tyi;
	Addrp length_var, string_var;
	expptr p;
	static char Writing_concatenation[] = "Writing concatenation";

/* Create the temporary arrays */

	n = ncat(rhs);
	length_var = mktmpn(n, tyioint, ENULL);
	string_var = mktmpn(n, TYADDR, ENULL);
	frtemp((Addrp)cpexpr((expptr)length_var));
	frtemp((Addrp)cpexpr((expptr)string_var));

/* Initialize the arrays */

	n = 0;
	/* p1_comment scribbles on its argument, so we
	 * cannot safely pass a string literal here. */
	p1_comment(Writing_concatenation);
	putct1(rhs, length_var, string_var, &n);

/* Create the invocation */

	tyi = tyint;
	tyint = tyioint;	/* for -I2 */
	p = putx (call4 (TYSUBR, "s_cat",
				(expptr)lhs,
				(expptr)string_var,
				(expptr)length_var,
				(expptr)putconst((Constp)ICON(n))));
	tyint = tyi;

	return p;
}





 LOCAL void
#ifdef KR_headers
putct1(q, length_var, string_var, ip)
	register expptr q;
	register Addrp length_var;
	register Addrp string_var;
	int *ip;
#else
putct1(register expptr q, register Addrp length_var, register Addrp string_var, int *ip)
#endif
{
	int i;
	Addrp length_copy, string_copy;
	expptr e;
	extern int szleng;

	if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT)
	{
		putct1(q->exprblock.leftp, length_var, string_var,
		    ip);
		putct1(q->exprblock.rightp, length_var, string_var,
		    ip);
		frexpr (q -> exprblock.vleng);
		free ((charptr) q);
	}
	else
	{
		i = (*ip)++;
		e = cpexpr(q->headblock.vleng);
		if (!e)
			return; /* error -- character*(*) */
		length_copy = (Addrp) cpexpr((expptr)length_var);
		length_copy->memoffset =
		    mkexpr(OPPLUS,length_copy->memoffset, ICON(i*szleng));
		string_copy = (Addrp) cpexpr((expptr)string_var);
		string_copy->memoffset =
		    mkexpr(OPPLUS, string_copy->memoffset,
			ICON(i*typesize[TYADDR]));
		putout (PAIR (putassign((expptr)length_copy, e),
			putassign((expptr)string_copy, addrof((expptr)putch1(q)))));
	}
}

/* putaddr -- seems to write out function invocation actual parameters */

	LOCAL expptr
#ifdef KR_headers
putaddr(p0)
	expptr p0;
#else
putaddr(expptr p0)
#endif
{
	register Addrp p;
	chainp cp;

	if (!(p = (Addrp)p0))
		return ENULL;

	if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) )
	{
		frexpr((expptr)p);
		return ENULL;
	}
	if (p->isarray && p->memoffset)
		if (p->uname_tag == UNAM_REF) {
			cp = p->memoffset->listblock.listp;
			for(; cp; cp = cp->nextp)
				cp->datap = (char *)fixtype((tagptr)cp->datap);
			}
		else
			p->memoffset = putx(p->memoffset);
	return (expptr) p;
}

 LOCAL expptr
#ifdef KR_headers
addrfix(e)
	expptr e;
#else
addrfix(expptr e)
#endif
		/* fudge character string length if it's a TADDR */
{
	return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e;
	}

 LOCAL int
#ifdef KR_headers
typekludge(ccall, q, at, j)
	int ccall;
	register expptr q;
	Atype *at;
	int j;
#else
typekludge(int ccall, register expptr q, Atype *at, int j)
#endif
 /* j = alternate type */
{
	register int i, k;
	extern int iocalladdr;
	register Namep np;

	/* Return value classes:
	 *	< 100 ==> Fortran arg (pointer to type)
	 *	< 200 ==> C arg
	 *	< 300 ==> procedure arg
	 *	< 400 ==> external, no explicit type
	 *	< 500 ==> arg that may turn out to be
	 *		  either a variable or a procedure
	 */

	k = q->headblock.vtype;
	if (ccall) {
		if (k == TYREAL)
			k = TYDREAL;	/* force double for library routines */
		return k + 100;
		}
	if (k == TYADDR)
		return iocalladdr;
	i = q->tag;
	if ((i == TEXPR && q->exprblock.opcode != OPCOMMA_ARG)
	||  (i == TADDR && q->addrblock.charleng)
	||   i == TCONST)
		k = TYFTNLEN + 100;
	else if (i == TADDR)
	    switch(q->addrblock.vclass) {
		case CLPROC:
			if (q->addrblock.uname_tag != UNAM_NAME)
				k += 200;
			else if ((np = q->addrblock.user.name)->vprocclass
					!= PTHISPROC) {
				if (k && !np->vimpltype)
					k += 200;
				else {
					if (j > 200 && infertypes && j < 300) {
						k = j;
						inferdcl(np, j-200);
						}
					else k = (np->vstg == STGEXT
						? extsymtab[np->vardesc.varno].extype
						: 0) + 200;
					at->cp = mkchain((char *)np, at->cp);
					}
				}
			else if (k == TYSUBR)
				k += 200;
			break;

		case CLUNKNOWN:
			if (q->addrblock.vstg == STGARG
			 && q->addrblock.uname_tag == UNAM_NAME) {
				k += 400;
				at->cp = mkchain((char *)q->addrblock.user.name,
						at->cp);
				}
		}
	else if (i == TNAME && q->nameblock.vstg == STGARG) {
		np = &q->nameblock;
		switch(np->vclass) {
		    case CLPROC:
			if (!np->vimpltype)
				k += 200;
			else if (j <= 200 || !infertypes || j >= 300)
				k += 300;
			else {
				k = j;
				inferdcl(np, j-200);
				}
			goto add2chain;

		    case CLUNKNOWN:
			/* argument may be a scalar variable or a function */
			if (np->vimpltype && j && infertypes
			&& j < 300) {
				inferdcl(np, j % 100);
				k = j;
				}
			else
				k += 400;

			/* to handle procedure args only so far known to be
			 * external, save a pointer to the symbol table entry...
		 	 */
 add2chain:
			at->cp = mkchain((char *)np, at->cp);
		    }
		}
	return k;
	}

 char *
#ifdef KR_headers
Argtype(k, buf)
	int k;
	char *buf;
#else
Argtype(int k, char *buf)
#endif
{
	if (k < 100) {
		sprintf(buf, "%s variable", ftn_types[k]);
		return buf;
		}
	if (k < 200) {
		k -= 100;
		return ftn_types[k];
		}
	if (k < 300) {
		k -= 200;
		if (k == TYSUBR)
			return ftn_types[TYSUBR];
		sprintf(buf, "%s function", ftn_types[k]);
		return buf;
		}
	if (k < 400)
		return "external argument";
	k -= 400;
	sprintf(buf, "%s argument", ftn_types[k]);
	return buf;
	}

 static void
#ifdef KR_headers
atype_squawk(at, msg)
	Argtypes *at;
	char *msg;
#else
atype_squawk(Argtypes *at, char *msg)
#endif
{
	register Atype *a, *ae;
	warn(msg);
	for(a = at->atypes, ae = a + at->nargs; a < ae; a++)
		frchain(&a->cp);
	at->nargs = -1;
	if (at->changes & 2 && !at->defined)
		proc_protochanges++;
	}