expr.c

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

	Lb = (struct Listblock *)cpexpr((tagptr)p->argsp);
	for(cp = Lb->listp; cp; cp = cp->nextp)
		cp->datap = (char *)putx(fixtype((tagptr)cp->datap));
	if (a->vtype == TYCHAR) {
		ep = p->fcharp	? mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1))
				: ICON(0);
		Lb->listp = mkchain((char *)ep, Lb->listp);
		}
	return (expptr)Lb;
	}

 static int doing_vleng;

/* mklhs -- Compute the actual address of the given expression; account
   for array subscripts, stack offset, and substring offsets.  The f -> C
   translator will need this only to worry about the subscript stuff */

 expptr
#ifdef KR_headers
mklhs(p, subkeep)
	register struct Primblock *p;
	int subkeep;
#else
mklhs(register struct Primblock *p, int subkeep)
#endif
{
	register Addrp s;
	Namep np;

	if(p->tag != TPRIM)
		return( (expptr) p );
	np = p->namep;

	replaced = 0;
	s = mkplace(np);
	if(s->tag!=TADDR || s->vstg==STGREG)
	{
		free( (charptr) p );
		return( (expptr) s );
	}
	s->parenused = p->parenused;

	/* compute the address modified by subscripts */

	if (!replaced)
		s->memoffset = (subkeep && np->vdim
				&& (np->vdim->ndim > 1 || np->vtype == TYCHAR
				&& (!ISCONST(np->vleng)
				  || np->vleng->constblock.Const.ci != 1)))
				? subskept(p,s)
				: mkexpr(OPPLUS, s->memoffset, suboffset(p) );
	frexpr((expptr)p->argsp);
	p->argsp = NULL;

	/* now do substring part */

	if(p->fcharp || p->lcharp)
	{
		if(np->vtype != TYCHAR)
			errstr("substring of noncharacter %s", np->fvarname);
		else	{
			if(p->lcharp == NULL)
				p->lcharp = (expptr) cpexpr(s->vleng);
			if(p->fcharp) {
				doing_vleng = 1;
				s->vleng = fixtype(mkexpr(OPMINUS,
						p->lcharp,
					mkexpr(OPMINUS, p->fcharp, ICON(1) )));
				doing_vleng = 0;
				}
			else	{
				frexpr(s->vleng);
				s->vleng = p->lcharp;
			}
		}
	}

	s->vleng = fixtype( s->vleng );
	s->memoffset = fixtype( s->memoffset );
	free( (charptr) p );
	return( (expptr) s );
}





/* deregister -- remove a register allocation from the list; assumes that
   names are deregistered in stack order (LIFO order - Last In First Out) */

 void
#ifdef KR_headers
deregister(np)
	Namep np;
#else
deregister(Namep np)
#endif
{
	if(nregvar>0 && regnamep[nregvar-1]==np)
	{
		--nregvar;
	}
}




/* memversion -- moves a DO index REGISTER into a memory location; other
   objects are passed through untouched */

 Addrp
#ifdef KR_headers
memversion(np)
	register Namep np;
#else
memversion(register Namep np)
#endif
{
	register Addrp s;

	if(np->vdovar==NO || (inregister(np)<0) )
		return(NULL);
	np->vdovar = NO;
	s = mkplace(np);
	np->vdovar = YES;
	return(s);
}



/* inregister -- looks for the input name in the global list   regnamep */

 int
#ifdef KR_headers
inregister(np)
	register Namep np;
#else
inregister(register Namep np)
#endif
{
	register int i;

	for(i = 0 ; i < nregvar ; ++i)
		if(regnamep[i] == np)
			return( regnum[i] );
	return(-1);
}



/* suboffset -- Compute the offset from the start of the array, given the
   subscripts as arguments */

 expptr
#ifdef KR_headers
suboffset(p)
	register struct Primblock *p;
#else
suboffset(register struct Primblock *p)
#endif
{
	int n;
	expptr si, size;
	chainp cp;
	expptr e, e1, offp, prod;
	struct Dimblock *dimp;
	expptr sub[MAXDIM+1];
	register Namep np;

	np = p->namep;
	offp = ICON(0);
	n = 0;
	if(p->argsp)
		for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
		{
			si = fixtype(cpexpr((tagptr)cp->datap));
			if (!ISINT(si->headblock.vtype)) {
				NOEXT("non-integer subscript");
				si = mkconv(TYLONG, si);
				}
			sub[n++] = si;
			if(n > maxdim)
			{
				erri("more than %d subscripts", maxdim);
				break;
			}
		}

	dimp = np->vdim;
	if(n>0 && dimp==NULL)
		errstr("subscripts on scalar variable %.68s", np->fvarname);
	else if(dimp && dimp->ndim!=n)
		errstr("wrong number of subscripts on %.68s", np->fvarname);
	else if(n > 0)
	{
		prod = sub[--n];
		while( --n >= 0)
			prod = mkexpr(OPPLUS, sub[n],
			    mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
		if(checksubs || np->vstg!=STGARG)
			prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));

/* Add in the run-time bounds check */

		if(checksubs)
			prod = subcheck(np, prod);
		size = np->vtype == TYCHAR ?
		    (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]);
		prod = mkexpr(OPSTAR, prod, size);
		offp = mkexpr(OPPLUS, offp, prod);
	}

/* Check for substring indicator */

	if(p->fcharp && np->vtype==TYCHAR) {
		e = p->fcharp;
		e1 = mkexpr(OPMINUS, cpexpr(e), ICON(1));
		if (!ISCONST(e) && (e->tag != TPRIM || e->primblock.argsp)) {
			e = (expptr)mktmp(TYLONG, ENULL);
			putout(putassign(cpexpr(e), e1));
			p->fcharp = mkexpr(OPPLUS, cpexpr(e), ICON(1));
			e1 = e;
			}
		offp = mkexpr(OPPLUS, offp, e1);
		}
	return(offp);
}




 expptr
#ifdef KR_headers
subcheck(np, p)
	Namep np;
	register expptr p;
#else
subcheck(Namep np, register expptr p)
#endif
{
	struct Dimblock *dimp;
	expptr t, checkvar, checkcond, badcall;

	dimp = np->vdim;
	if(dimp->nelt == NULL)
		return(p);	/* don't check arrays with * bounds */
	np->vlastdim = 0;
	if( ISICON(p) )
	{

/* check for negative (constant) offset */

		if(p->constblock.Const.ci < 0)
			goto badsub;
		if( ISICON(dimp->nelt) )

/* see if constant offset exceeds the array declaration */

			if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci)
				return(p);
			else
				goto badsub;
	}

/* We know that the subscript offset   p   or   dimp -> nelt   is not a constant.
   Now find a register to use for run-time bounds checking */

	if(p->tag==TADDR && p->addrblock.vstg==STGREG)
	{
		checkvar = (expptr) cpexpr(p);
		t = p;
	}
	else	{
		checkvar = (expptr) mktmp(p->headblock.vtype, ENULL);
		t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
	}
	checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
	if( ! ISICON(p) )
		checkcond = mkexpr(OPAND, checkcond,
		    mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );

/* Construct the actual test */

	badcall = call4(p->headblock.vtype, "s_rnge",
	    mkstrcon(strlen(np->fvarname), np->fvarname),
	    mkconv(TYLONG,  cpexpr(checkvar)),
	    mkstrcon(strlen(procname), procname),
	    ICON(lineno) );
	badcall->exprblock.opcode = OPCCALL;
	p = mkexpr(OPQUEST, checkcond,
	    mkexpr(OPCOLON, checkvar, badcall));

	return(p);

badsub:
	frexpr(p);
	errstr("subscript on variable %s out of range", np->fvarname);
	return ( ICON(0) );
}




 Addrp
#ifdef KR_headers
mkaddr(p)
	register Namep p;
#else
mkaddr(register Namep p)
#endif
{
	Extsym *extp;
	register Addrp t;
	int k;

	switch( p->vstg)
	{
	case STGAUTO:
		if(p->vclass == CLPROC && p->vprocclass == PTHISPROC)
			return (Addrp) cpexpr((expptr)xretslot[p->vtype]);
		goto other;

	case STGUNKNOWN:
		if(p->vclass != CLPROC)
			break;	/* Error */
		extp = mkext(p->fvarname, addunder(p->cvarname));
		extp->extstg = STGEXT;
		p->vstg = STGEXT;
		p->vardesc.varno = extp - extsymtab;
		p->vprocclass = PEXTERNAL;
		if ((extp->exproto || infertypes)
		&& (p->vtype == TYUNKNOWN || p->vimpltype)
		&& (k = extp->extype))
			inferdcl(p, k);


	case STGCOMMON:
	case STGEXT:
	case STGBSS:
	case STGINIT:
	case STGEQUIV:
	case STGARG:
	case STGLENG:
 other:
		t = ALLOC(Addrblock);
		t->tag = TADDR;

		t->vclass = p->vclass;
		t->vtype = p->vtype;
		t->vstg = p->vstg;
		t->memno = p->vardesc.varno;
		t->memoffset = ICON(p->voffset);
		if (p->vdim)
		    t->isarray = 1;
		if(p->vleng)
		{
			t->vleng = (expptr) cpexpr(p->vleng);
			if( ISICON(t->vleng) )
				t->varleng = t->vleng->constblock.Const.ci;
		}

/* Keep the original name around for the C code generation */

		t -> uname_tag = UNAM_NAME;
		t -> user.name = p;
		return(t);

	case STGINTR:

		return ( intraddr (p));

	case STGSTFUNCT:

		errstr("invalid use of statement function %.64s.", p->fvarname);
		return putconst((Constp)ICON(0));
	}
	badstg("mkaddr", p->vstg);
	/* NOT REACHED */ return 0;
}




/* mkarg -- create storage for a new parameter.  This is called when a
   function returns a string (for the return value, which is the first
   parameter), or when a variable-length string is passed to a function. */

 Addrp
#ifdef KR_headers
mkarg(type, argno)
	int type;
	int argno;
#else
mkarg(int type, int argno)
#endif
{
	register Addrp p;

	p = ALLOC(Addrblock);
	p->tag = TADDR;
	p->vtype = type;
	p->vclass = CLVAR;

/* TYLENG is the type of the field holding the length of a character string */

	p->vstg = (type==TYLENG ? STGLENG : STGARG);
	p->memno = argno;
	return(p);
}




/* mkprim -- Create a PRIM (primary/primitive) block consisting of a
   Nameblock (or Paramblock), arguments (actual params or array
   subscripts) and substring bounds.  Requires that   v   have lots of
   extra (uninitialized) storage, since it could be a paramblock or
   nameblock */

 expptr
#ifdef KR_headers
mkprim(v0, args, substr)
	Namep v0;
	struct Listblock *args;
	chainp substr;
#else
mkprim(Namep v0, struct Listblock *args, chainp substr)
#endif
{
	typedef union {
		struct Paramblock paramblock;
		struct Nameblock nameblock;
		struct Headblock headblock;
		} *Primu;
	register Primu v = (Primu)v0;
	register struct Primblock *p;

	if(v->headblock.vclass == CLPARAM)
	{

/* v   is to be a Paramblock */

		if(args || substr)
		{
			errstr("no qualifiers on parameter name %s",
			    v->paramblock.fvarname);
			frexpr((expptr)args);
			if(substr)
			{
				frexpr((tagptr)substr->datap);
				frexpr((tagptr)substr->nextp->datap);
				frchain(&substr);
			}
			frexpr((expptr)v);
			return( errnode() );
		}
		return( (expptr) cpexpr(v->paramblock.paramval) );
	}

	p = ALLOC(Primblock);
	p->tag = TPRIM;
	p->vtype = v->nameblock.vtype;

/* v   is to be a Nameblock */

	p->namep = (Namep) v;
	p->argsp = args;
	if(substr)
	{
		p->fcharp = (expptr) substr->datap;
		p->lcharp = (expptr) substr->nextp->datap;
		frchain(&substr);
	}
	return( (expptr) p);
}



/* vardcl -- attempt to fill out the Name template for variable   v.
   This function is called on identifiers known to be variables or
   recursive references to the same function */

 void
#ifdef KR_headers
vardcl(v)
	register Namep v;
#else
vardcl(register Namep v)
#endif
{
	struct Dimblock *t;
	expptr neltp;
	extern int doing_stmtfcn;

	if(v->vclass == CLUNKNOWN) {
		v->vclass = CLVAR;
		if (v->vinftype) {
			v->vtype = TYUNKNOWN;
			if (v->vdcldone) {
				v->vdcldone = 0;
				impldcl(v);
				}
			}
		}
	if(v->vdcldone)
		return;
	if(v->vclass == CLNAMELIST)
		return;

	if(v->vtype == TYUNKNOWN)
		impldcl(v);
	else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
	{
		dclerr("used as variable", v);
		return;
	}
	if(v->vstg==STGUNKNOWN) {
		if (doing_stmtfcn) {
			/* neither declare this variable if its only use */
			/* is in defining a stmt function, nor complain  */
			/* that it is never used */
			v->vimpldovar = 1;
			return;
			}
		v->vstg = implstg[ letter(v->fvarname[0]) ];
		v->vimplstg = 1;
		}

/* Compute the actual storage location, i.e. offsets from base addresses,
   possibly the stack pointer */

	switch(v->vstg)
	{
	case STGBSS:
		v->vardesc.varno = ++lastvarno;
		break;
	case STGAUTO:
		if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
			break;
		if(t = v->vdim)
			if( (neltp = t->nelt) && ISCONST(neltp) ) ;
			else
				dclerr("adjustable automatic array", v);
		break;

	default:
		break;
	}
	v->vdcldone = YES;
}



/* Set the implicit type declaration of parameter   p   based on its first
   letter */

 void
#ifdef KR_headers
impldcl(p)
	register Namep p;
#else
impldcl(register Namep p)
#endif
{
	register int k;
	int type;
	ftnint leng;

	if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
		return;
	if(p->vtype == TYUNKNOWN)
	{
		k = letter(p->fvarname[0]);
		type = impltype[ k ];
		leng = implleng[ k ];
		if(type == TYUNKNOWN)
		{
			if(p->vclass == CLPROC)
				return;
			dclerr("attempt to use undefined variable", p);
			type = dflttype[k];
			leng = 0;
		}
		settype(p, type, leng);
		p->vimpltype = 1;
	}
}

 void
#ifdef KR_headers
inferdcl(np, type)
	Namep np;
	int type;
#else
inferdcl(Namep np, int type)
#endif
{
	int k = impltype[letter(np->fvarname[0])];
	if (k != type) {
		np->vinftype = 1;
		np->vtype = type;
		frexpr(np->vleng);
		np->vleng = 0;
		}
	np->vimpltype = 0;
	np->vinfproc = 1;
	}

 LOCAL int
#ifdef KR_headers
zeroconst(e)
	expptr e;
#else
zeroconst(expptr e)
#endif
{
	register Constp c = (Constp) e;
	if (c->tag == TCONST)
		switch(c->vtype) {
		case TYINT1:
		case TYSHORT:
		case TYLONG:
#ifdef TYQUAD
		case TYQUAD:
#endif
			return c->Const.ci == 0;

		case TYREAL:
		case TYDREAL:
			if (c->vstg == 1)
				return !strcmp(c->Const.cds[0],"0.");
			return c->Const.cd[0] == 0.;

		case TYCOMPLEX:
		case TYDCOMPLEX:
			if (c->vstg == 1)
				return !strcmp(c->Const.cds[0],"0.")
				    && !strcmp(c->Const.cds[1],"0.");
			return c->Const.cd[0] == 0. && c->Const.cd[1] == 0.;
		}
	return 0;
	}


#define ICONEQ(z, c)  (ISICON(z) && z->constblock.Const.ci==c)
#define COMMUTE	{ e = lp;  lp = rp;  rp = e; }

/* mkexpr -- Make expression, and simplify constant subcomponents (tree
   order is not preserved).  Assumes that   lp   is nonempty, and uses
   fold()   to simplify adjacent constants */

 expptr
#ifdef KR_headers
mkexpr(opcode, lp, rp)
	int opcode;
	register expptr lp;
	register expptr rp;
#else
mkexpr(int opcode, register expptr lp, register expptr rp)
#endif
{
	register expptr e, e1;
	int etype;
	int ltype, rtype;