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

#include "defs.h"
#include "output.h"
#include "names.h"

typedef struct { double dreal, dimag; } dcomplex;

static void consbinop Argdcl((int, int, Constp, Constp, Constp));
static void conspower Argdcl((Constp, Constp, long int));
static void zdiv Argdcl((dcomplex*, dcomplex*, dcomplex*));
static tagptr mkpower Argdcl((tagptr));
static tagptr stfcall Argdcl((Namep, struct Listblock*));

extern char dflttype[26];
extern int htype;

/* little routines to create constant blocks */

 Constp
#ifdef KR_headers
mkconst(t)
	register int t;
#else
mkconst(register int t)
#endif
{
	register Constp p;

	p = ALLOC(Constblock);
	p->tag = TCONST;
	p->vtype = t;
	return(p);
}


/* mklogcon -- Make Logical Constant */

 expptr
#ifdef KR_headers
mklogcon(l)
	register int l;
#else
mklogcon(register int l)
#endif
{
	register Constp  p;

	p = mkconst(tylog);
	p->Const.ci = l;
	return( (expptr) p );
}



/* mkintcon -- Make Integer Constant */

 expptr
#ifdef KR_headers
mkintcon(l)
	ftnint l;
#else
mkintcon(ftnint l)
#endif
{
	register Constp p;

	p = mkconst(tyint);
	p->Const.ci = l;
	return( (expptr) p );
}




/* mkaddcon -- Make Address Constant, given integer value */

 expptr
#ifdef KR_headers
mkaddcon(l)
	register long l;
#else
mkaddcon(register long l)
#endif
{
	register Constp p;

	p = mkconst(TYADDR);
	p->Const.ci = l;
	return( (expptr) p );
}



/* mkrealcon -- Make Real Constant.  The type t is assumed
   to be TYREAL or TYDREAL */

 expptr
#ifdef KR_headers
mkrealcon(t, d)
	register int t;
	char *d;
#else
mkrealcon(register int t, char *d)
#endif
{
	register Constp p;

	p = mkconst(t);
	p->Const.cds[0] = cds(d,CNULL);
	p->vstg = 1;
	return( (expptr) p );
}


/* mkbitcon -- Make bit constant.  Reads the input string, which is
   assumed to correctly specify a number in base 2^shift (where   shift
   is the input parameter).   shift   may not exceed 4, i.e. only binary,
   quad, octal and hex bases may be input.  Constants may not exceed 32
   bits, or whatever the size of (struct Constblock).ci may be. */

 expptr
#ifdef KR_headers
mkbitcon(shift, leng, s)
	int shift;
	int leng;
	char *s;
#else
mkbitcon(int shift, int leng, char *s)
#endif
{
	register Constp p;
	register long x;

	p = mkconst(TYLONG);
	x = 0;
	while(--leng >= 0)
		if(*s != ' ')
			x = (x << shift) | hextoi(*s++);
	/* mwm wanted to change the type to short for short constants,
	 * but this is dangerous -- there is no syntax for long constants
	 * with small values.
	 */
	p->Const.ci = x;
	return( (expptr) p );
}





/* mkstrcon -- Make string constant.  Allocates storage and initializes
   the memory for a copy of the input Fortran-string. */

 expptr
#ifdef KR_headers
mkstrcon(l, v)
	int l;
	register char *v;
#else
mkstrcon(int l, register char *v)
#endif
{
	register Constp p;
	register char *s;

	p = mkconst(TYCHAR);
	p->vleng = ICON(l);
	p->Const.ccp = s = (char *) ckalloc(l+1);
	p->Const.ccp1.blanks = 0;
	while(--l >= 0)
		*s++ = *v++;
	*s = '\0';
	return( (expptr) p );
}



/* mkcxcon -- Make complex contsant.  A complex number is a pair of
   values, each of which may be integer, real or double. */

 expptr
#ifdef KR_headers
mkcxcon(realp, imagp)
	register expptr realp;
	register expptr imagp;
#else
mkcxcon(register expptr realp, register expptr imagp)
#endif
{
	int rtype, itype;
	register Constp p;

	rtype = realp->headblock.vtype;
	itype = imagp->headblock.vtype;

	if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
	{
		p = mkconst( (rtype==TYDREAL||itype==TYDREAL)
				? TYDCOMPLEX : tycomplex);
		if (realp->constblock.vstg || imagp->constblock.vstg) {
			p->vstg = 1;
			p->Const.cds[0] = ISINT(rtype)
				? string_num("", realp->constblock.Const.ci)
				: realp->constblock.vstg
					? realp->constblock.Const.cds[0]
					: dtos(realp->constblock.Const.cd[0]);
			p->Const.cds[1] = ISINT(itype)
				? string_num("", imagp->constblock.Const.ci)
				: imagp->constblock.vstg
					? imagp->constblock.Const.cds[0]
					: dtos(imagp->constblock.Const.cd[0]);
			}
		else {
			p->Const.cd[0] = ISINT(rtype)
				? realp->constblock.Const.ci
				: realp->constblock.Const.cd[0];
			p->Const.cd[1] = ISINT(itype)
				? imagp->constblock.Const.ci
				: imagp->constblock.Const.cd[0];
			}
	}
	else
	{
		err("invalid complex constant");
		p = (Constp)errnode();
	}

	frexpr(realp);
	frexpr(imagp);
	return( (expptr) p );
}


/* errnode -- Allocate a new error block */

 expptr
errnode(Void)
{
	struct Errorblock *p;
	p = ALLOC(Errorblock);
	p->tag = TERROR;
	p->vtype = TYERROR;
	return( (expptr) p );
}





/* mkconv -- Make type conversion.  Cast expression   p   into type   t.
   Note that casting to a character copies only the first sizeof(char)
   bytes. */

 expptr
#ifdef KR_headers
mkconv(t, p)
	register int t;
	register expptr p;
#else
mkconv(register int t, register expptr p)
#endif
{
	register expptr q;
	register int pt, charwarn = 1;

	if (t >= 100) {
		t -= 100;
		charwarn = 0;
		}
	if(t==TYUNKNOWN || t==TYERROR)
		badtype("mkconv", t);
	pt = p->headblock.vtype;

/* Casting to the same type is a no-op */

	if(t == pt)
		return(p);

/* If we're casting a constant which is not in the literal table ... */

	else if( ISCONST(p) && pt!=TYADDR && pt != TYCHAR)
	{
		if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) {
			/* avoid trouble with -i2 */
			p->headblock.vtype = t;
			return p;
			}
		q = (expptr) mkconst(t);
		consconv(t, &q->constblock, &p->constblock );
		frexpr(p);
	}
	else {
		if (pt == TYCHAR && t != TYADDR && charwarn
				&& (!halign || p->tag != TADDR
				|| p->addrblock.uname_tag != UNAM_CONST))
			warn(
		 "ichar([first char. of] char. string) assumed for conversion to numeric");
		q = opconv(p, t);
		}

	if(t == TYCHAR)
		q->constblock.vleng = ICON(1);
	return(q);
}



/* opconv -- Convert expression   p   to type   t   using the main
   expression evaluator; returns an OPCONV expression, I think  14-jun-88 mwm */

 expptr
#ifdef KR_headers
opconv(p, t)
	expptr p;
	int t;
#else
opconv(expptr p, int t)
#endif
{
	register expptr q;

	if (t == TYSUBR)
		err("illegal use of subroutine name");
	q = mkexpr(OPCONV, p, ENULL);
	q->headblock.vtype = t;
	return(q);
}



/* addrof -- Create an ADDR expression operation */

 expptr
#ifdef KR_headers
addrof(p)
	expptr p;
#else
addrof(expptr p)
#endif
{
	return( mkexpr(OPADDR, p, ENULL) );
}



/* cpexpr - Returns a new copy of input expression   p   */

 tagptr
#ifdef KR_headers
cpexpr(p)
	register tagptr p;
#else
cpexpr(register tagptr p)
#endif
{
	register tagptr e;
	int tag;
	register chainp ep, pp;

/* This table depends on the ordering of the T macros, e.g. TNAME */

	static int blksize[ ] =
	{
		0,
		sizeof(struct Nameblock),
		sizeof(struct Constblock),
		sizeof(struct Exprblock),
		sizeof(struct Addrblock),
		sizeof(struct Primblock),
		sizeof(struct Listblock),
		sizeof(struct Impldoblock),
		sizeof(struct Errorblock)
	};

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

/* TNAMEs are special, and don't get copied.  Each name in the current
   symbol table has a unique TNAME structure. */

	if( (tag = p->tag) == TNAME)
		return(p);

	e = cpblock(blksize[p->tag], (char *)p);

	switch(tag)
	{
	case TCONST:
		if(e->constblock.vtype == TYCHAR)
		{
			e->constblock.Const.ccp =
			    copyn((int)e->constblock.vleng->constblock.Const.ci+1,
				e->constblock.Const.ccp);
			e->constblock.vleng =
			    (expptr) cpexpr(e->constblock.vleng);
		}
	case TERROR:
		break;

	case TEXPR:
		e->exprblock.leftp =  (expptr) cpexpr(p->exprblock.leftp);
		e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp);
		break;

	case TLIST:
		if(pp = p->listblock.listp)
		{
			ep = e->listblock.listp =
			    mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL);
			for(pp = pp->nextp ; pp ; pp = pp->nextp)
				ep = ep->nextp =
				    mkchain((char *)cpexpr((tagptr)pp->datap),
						CHNULL);
		}
		break;

	case TADDR:
		e->addrblock.vleng = (expptr)  cpexpr(e->addrblock.vleng);
		e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset);
		e->addrblock.istemp = NO;
		break;

	case TPRIM:
		e->primblock.argsp = (struct Listblock *)
		    cpexpr((expptr)e->primblock.argsp);
		e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp);
		e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp);
		break;

	default:
		badtag("cpexpr", tag);
	}

	return(e);
}

/* frexpr -- Free expression -- frees up memory used by expression   p   */

 void
#ifdef KR_headers
frexpr(p)
	register tagptr p;
#else
frexpr(register tagptr p)
#endif
{
	register chainp q;

	if(p == NULL)
		return;

	switch(p->tag)
	{
	case TCONST:
		if( ISCHAR(p) )
		{
			free( (charptr) (p->constblock.Const.ccp) );
			frexpr(p->constblock.vleng);
		}
		break;

	case TADDR:
		if (p->addrblock.vtype > TYERROR)	/* i/o block */
			break;
		frexpr(p->addrblock.vleng);
		frexpr(p->addrblock.memoffset);
		break;

	case TERROR:
		break;

/* TNAME blocks don't get free'd - probably because they're pointed to in
   the hash table. 14-Jun-88 -- mwm */

	case TNAME:
		return;

	case TPRIM:
		frexpr((expptr)p->primblock.argsp);
		frexpr(p->primblock.fcharp);
		frexpr(p->primblock.lcharp);
		break;

	case TEXPR:
		frexpr(p->exprblock.leftp);
		if(p->exprblock.rightp)
			frexpr(p->exprblock.rightp);
		break;

	case TLIST:
		for(q = p->listblock.listp ; q ; q = q->nextp)
			frexpr((tagptr)q->datap);
		frchain( &(p->listblock.listp) );
		break;

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

	free( (charptr) p );
}

 void
#ifdef KR_headers
wronginf(np)
	Namep np;
#else
wronginf(Namep np)
#endif
{
	int c, k;
	warn1("fixing wrong type inferred for %.65s", np->fvarname);
	np->vinftype = 0;
	c = letter(np->fvarname[0]);
	if ((np->vtype = impltype[c]) == TYCHAR
	&& (k = implleng[c]))
		np->vleng = ICON(k);
	}

/* fix up types in expression; replace subtrees and convert
   names to address blocks */

 expptr
#ifdef KR_headers
fixtype(p)
	register tagptr p;
#else
fixtype(register tagptr p)
#endif
{

	if(p == 0)
		return(0);

	switch(p->tag)
	{
	case TCONST:
		if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR|
		    MSKREAL) )
			return( (expptr) p);

		return( (expptr) putconst((Constp)p) );

	case TADDR:
		p->addrblock.memoffset = fixtype(p->addrblock.memoffset);
		return( (expptr) p);

	case TERROR:
		return( (expptr) p);

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

/* This case means that   fixexpr   can't call   fixtype   with any expr,
   only a subexpr of its parameter. */

	case TEXPR:
		if (((Exprp)p)->typefixed)
			return (expptr)p;
		return( fixexpr((Exprp)p) );

	case TLIST:
		return( (expptr) p );

	case TPRIM:
		if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR)
		{
			if(p->primblock.namep->vtype == TYSUBR)
			{
				err("function invocation of subroutine");
				return( errnode() );
			}
			else {
				if (p->primblock.namep->vinftype)
					wronginf(p->primblock.namep);
				return( mkfunct(p) );
				}
		}

/* The lack of args makes   p   a function name, substring reference
   or variable name. */

		else	return mklhs((struct Primblock *) p, keepsubs);
	}
}


 int
#ifdef KR_headers
badchleng(p)
	register expptr p;
#else
badchleng(register expptr p)
#endif
{
	if (!p->headblock.vleng) {
		if (p->headblock.tag == TADDR
		&& p->addrblock.uname_tag == UNAM_NAME)
			errstr("bad use of character*(*) variable %.60s",
				p->addrblock.user.name->fvarname);
		else
			err("Bad use of character*(*)");
		return 1;
		}
	return 0;
	}


 static expptr
#ifdef KR_headers
cplenexpr(p)
	expptr p;
#else
cplenexpr(expptr p)
#endif
{
	expptr rv;

	if (badchleng(p))
		return ICON(1);
	rv = cpexpr(p->headblock.vleng);
	if (ISCONST(p) && p->constblock.vtype == TYCHAR)
		rv->constblock.Const.ci += p->constblock.Const.ccp1.blanks;
	return rv;
	}


/* special case tree transformations and cleanups of expression trees.
   Parameter   p   should have a TEXPR tag at its root, else an error is
   returned */

 expptr
#ifdef KR_headers
fixexpr(p)
	register Exprp p;
#else
fixexpr(register Exprp p)
#endif
{
	expptr lp;
	register expptr rp;
	register expptr q;