exec.c

来自「把fortran语言编的程序转为c语言编的程序, 运行环境linux」· C语言 代码 · 共 927 行 · 第 1/2 页

				dclerr("already declared; cannot be a loop name",
					loopname);
			}
#endif
		putwhile((expptr)spec->nextp);
		NOEXT("do while");
		spec->nextp = 0;
		frchain(&spec);
		return;
		}
	if(np->vdovar)
	{
		errstr("nested loops with variable %s", np->fvarname);
		ctlstack->donamep = NULL;
		return;
	}

/* Create a memory-resident version of the index variable */

	dovarp = mkplace(np);
	if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) )
	{
		err("bad type on do variable");
		return;
	}
	ctlstack->donamep = np;

	np->vdovar = YES;

/* Now   dovarp   points to the index to be used within the loop,   dostgp
   points to the one which may need to be stored */

	dotype = dovarp->vtype;

/* Count the input specifications and type-check each one independently;
   this just eliminates non-numeric values from the specification */

	for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
	{
		p = par[i++] = fixtype((tagptr)cp->datap);
		if( ! ONEOF(p->headblock.vtype, MSKINT|MSKREAL) )
		{
			err("bad type on DO parameter");
			return;
		}
	}

	frchain(&spec);
	switch(i)
	{
	case 0:
	case 1:
		err("too few DO parameters");
		return;

	default:
		err("too many DO parameters");
		return;

	case 2:
		DOINCR = (expptr) ICON(1);

	case 3:
		break;
	}


/* Now all of the local specification fields are set, but their types are
   not yet consistent */

/* Declare the loop initialization value, casting it properly and declaring a
   register if need be */

	if (ISCONST (DOINIT) || !onetripflag)
/* putx added 6-29-89 (mwm), not sure if fixtype is required, but I doubt it
   since mkconv is called just before */
		doinit = putx (mkconv (dotype, DOINIT));
	else {
	    doinit = (expptr) mktmp(dotype, ENULL);
	    puteq (cpexpr (doinit), DOINIT);
	} /* else */

/* Declare the loop ending value, casting it to the type of the index
   variable */

	if( ISCONST(DOLIMIT) )
		ctlstack->domax = mkconv(dotype, DOLIMIT);
	else {
		ctlstack->domax = (expptr) mktmp0(dotype, ENULL);
		puteq (cpexpr (ctlstack -> domax), DOLIMIT);
	} /* else */

/* Declare the loop increment value, casting it to the type of the index
   variable */

	if( ISCONST(DOINCR) )
	{
		ctlstack->dostep = mkconv(dotype, DOINCR);
		if( (incsign = conssgn(ctlstack->dostep)) == 0)
			err("zero DO increment");
		ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
	}
	else
	{
		ctlstack->dostep = (expptr) mktmp0(dotype, ENULL);
		ctlstack->dostepsign = VARSTEP;
		puteq (cpexpr (ctlstack -> dostep), DOINCR);
	}

/* All data is now properly typed and in the   ctlstack,   except for the
   initial value.  Assignments of temps have been generated already */

	switch (ctlstack -> dostepsign) {
	    case VARSTEP:
		test = mkexpr (OPQUEST, mkexpr (OPLT,
			cpexpr (ctlstack -> dostep), ICON(0)),
			mkexpr (OPCOLON,
			    mkexpr (OPGE, cpexpr((expptr)dovarp),
				    cpexpr (ctlstack -> domax)),
			    mkexpr (OPLE, cpexpr((expptr)dovarp),
				    cpexpr (ctlstack -> domax))));
		break;
	    case POSSTEP:
	        test = mkexpr (OPLE, cpexpr((expptr)dovarp),
			cpexpr (ctlstack -> domax));
	        break;
	    case NEGSTEP:
	        test = mkexpr (OPGE, cpexpr((expptr)dovarp),
			cpexpr (ctlstack -> domax));
	        break;
	    default:
	        erri ("exdo:  bad dostepsign '%d'", ctlstack -> dostepsign);
	        break;
	} /* switch (ctlstack -> dostepsign) */

	if (onetripflag)
	    test = mkexpr (OPOR, test,
		    mkexpr (OPEQ, cpexpr((expptr)dovarp), cpexpr (doinit)));
	init = mkexpr (OPASSIGN, cpexpr((expptr)dovarp), doinit);
	inc = mkexpr (OPPLUSEQ, (expptr)dovarp, cpexpr (ctlstack -> dostep));

	if (!onetripflag && ISCONST (ctlstack -> domax) && ISCONST (doinit)
		&& ctlstack -> dostepsign != VARSTEP) {
	    expptr tester;

	    tester = mkexpr (OPMINUS, cpexpr (doinit),
		    cpexpr (ctlstack -> domax));
	    if (incsign == conssgn (tester))
		warn ("DO range never executed");
	    frexpr (tester);
	} /* if !onetripflag && */

	p1_for (init, test, inc);
}

 void
#ifdef KR_headers
exenddo(np)
	Namep np;
#else
exenddo(Namep np)
#endif
{
	Namep np1;
	int here;
	struct Ctlframe *cf;

	if( ctlstack < ctls )
		goto misplaced;
	here = ctlstack->dolabel;
	if (ctlstack->ctltype != CTLDO
	|| here >= 0 && (!thislabel || thislabel->labelno != here)) {
 misplaced:
		err("misplaced ENDDO");
		return;
		}
	if (np != ctlstack->loopname) {
		if (np1 = ctlstack->loopname)
			errstr("expected \"enddo %s\"", np1->fvarname);
		else
			err("expected unnamed ENDDO");
		for(cf = ctls; cf < ctlstack; cf++)
			if (cf->ctltype == CTLDO && cf->loopname == np) {
				here = cf->dolabel;
				break;
				}
		}
	enddo(here);
	}

 void
#ifdef KR_headers
enddo(here)
	int here;
#else
enddo(int here)
#endif
{
	register struct Ctlframe *q;
	Namep np;			/* name of the current DO index */
	Addrp ap;
	register int i;
	register expptr e;

/* Many DO's can end at the same statement, so keep looping over all
   nested indicies */

	while(here == dorange)
	{
		if(np = ctlstack->donamep)
			{
			p1for_end ();

/* Now we're done with all of the tests, and the loop has terminated.
   Store the index value back in long-term memory */

			if(ap = memversion(np))
				puteq((expptr)ap, (expptr)mkplace(np));
			for(i = 0 ; i < 4 ; ++i)
				ctlstack->ctlabels[i] = 0;
			deregister(ctlstack->donamep);
			ctlstack->donamep->vdovar = NO;
			/* ctlstack->dostep and ctlstack->domax can be zero */
			/* with sufficiently bizarre (erroneous) syntax */
			if (e = ctlstack->dostep)
				if (e->tag == TADDR && e->addrblock.istemp)
					frtemp((Addrp)e);
				else
					frexpr(e);
			if (e = ctlstack->domax)
				if (e->tag == TADDR && e->addrblock.istemp)
					frtemp((Addrp)e);
				else
					frexpr(e);
			}
		else if (ctlstack->dowhile)
			p1for_end ();

/* Set   dorange   to the closing label of the next most enclosing DO loop
   */

		popctl();
		poplab();
		dorange = 0;
		for(q = ctlstack ; q>=ctls ; --q)
			if(q->ctltype == CTLDO)
			{
				dorange = q->dolabel;
				break;
			}
	}
}

 void
#ifdef KR_headers
exassign(vname, labelval)
	register Namep vname;
	struct Labelblock *labelval;
#else
exassign(register Namep vname, struct Labelblock *labelval)
#endif
{
	Addrp p;
	register Addrp q;
	char *fs;
	register chainp cp, cpprev;
	register ftnint k, stno;

	p = mkplace(vname);
	if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) {
		err("noninteger assign variable");
		return;
		}

	/* If the label hasn't been defined, then we do things twice:
	 * once for an executable stmt label, once for a format
	 */

	/* code for executable label... */

/* Now store the assigned value in a list associated with this variable.
   This will be used later to generate a switch() statement in the C output */

	fs = labelval->fmtstring;
	if (!labelval->labdefined || !fs) {

		if (vname -> vis_assigned == 0) {
			vname -> varxptr.assigned_values = CHNULL;
			vname -> vis_assigned = 1;
			}

		/* don't duplicate labels... */

		stno = labelval->stateno;
		cpprev = 0;
		for(k = 0, cp = vname->varxptr.assigned_values;
				cp; cpprev = cp, cp = cp->nextp, k++)
			if ((ftnint)cp->datap == stno)
				break;
		if (!cp) {
			cp = mkchain((char *)stno, CHNULL);
			if (cpprev)
				cpprev->nextp = cp;
			else
				vname->varxptr.assigned_values = cp;
			labelval->labused = 1;
			}
		putout(mkexpr(OPASSIGN, (expptr)p, mkintcon(k)));
		}

	/* Code for FORMAT label... */

	if (!labelval->labdefined || fs) {

		labelval->fmtlabused = 1;
		p = ALLOC(Addrblock);
		p->tag = TADDR;
		p->vtype = TYCHAR;
		p->vstg = STGAUTO;
		p->memoffset = ICON(0);
		fmtname(vname, p);
		q = ALLOC(Addrblock);
		q->tag = TADDR;
		q->vtype = TYCHAR;
		q->vstg = STGAUTO;
		q->ntempelt = 1;
		q->memoffset = ICON(0);
		q->uname_tag = UNAM_IDENT;
		sprintf(q->user.ident, "fmt_%ld", labelval->stateno);
		putout(mkexpr(OPASSIGN, (expptr)p, (expptr)q));
		}

} /* exassign */


 void
#ifdef KR_headers
exarif(expr, neglab, zerlab, poslab)
	expptr expr;
	struct Labelblock *neglab;
	struct Labelblock *zerlab;
	struct Labelblock *poslab;
#else
exarif(expptr expr, struct Labelblock *neglab, struct Labelblock *zerlab, struct Labelblock *poslab)
#endif
{
    register int lm, lz, lp;

    lm = neglab->stateno;
    lz = zerlab->stateno;
    lp = poslab->stateno;
    expr = fixtype(expr);

    if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) )
    {
        err("invalid type of arithmetic if expression");
        frexpr(expr);
    }
    else
    {
        if (lm == lz && lz == lp)
            exgoto (neglab);
        else if(lm == lz)
            exar2(OPLE, expr, neglab, poslab);
        else if(lm == lp)
            exar2(OPNE, expr, neglab, zerlab);
        else if(lz == lp)
            exar2(OPGE, expr, zerlab, neglab);
        else {
            expptr t;

	    if (!addressable (expr)) {
		t = (expptr) mktmp(expr -> headblock.vtype, ENULL);
		expr = mkexpr (OPASSIGN, cpexpr (t), expr);
	    } else
		t = (expptr) cpexpr (expr);

	    p1_if(putx(fixtype(mkexpr (OPLT, expr, ICON (0)))));
	    exgoto(neglab);
	    p1_elif (mkexpr (OPEQ, t, ICON (0)));
	    exgoto(zerlab);
	    p1_else ();
	    exgoto(poslab);
	    p1else_end ();
        } /* else */
    }
}



/* exar2 -- Do arithmetic IF for only 2 distinct labels;   if !(e.op.0)
   goto l2 else goto l1.  If this seems backwards, that's because it is,
   in order to make the 1 pass algorithm work. */

 LOCAL void
#ifdef KR_headers
exar2(op, e, l1, l2)
	int op;
	expptr e;
	struct Labelblock *l1;
	struct Labelblock *l2;
#else
exar2(int op, expptr e, struct Labelblock *l1, struct Labelblock *l2)
#endif
{
	expptr comp;

	comp = mkexpr (op, e, ICON (0));
	p1_if(putx(fixtype(comp)));
	exgoto(l1);
	p1_else ();
	exgoto(l2);
	p1else_end ();
}


/* exreturn -- return the value in   p  from a SUBROUTINE call -- used to
   implement the alternate return mechanism */

 void
#ifdef KR_headers
exreturn(p)
	register expptr p;
#else
exreturn(register expptr p)
#endif
{
	if(procclass != CLPROC)
		warn("RETURN statement in main or block data");
	if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
	{
		err("alternate return in nonsubroutine");
		p = 0;
	}

	if (p || proctype == TYSUBR) {
		if (p == ENULL) p = ICON (0);
		p = mkconv (TYLONG, fixtype (p));
		p1_subr_ret (p);
	} /* if p || proctype == TYSUBR */
	else
	    p1_subr_ret((expptr)retslot);
}


 void
#ifdef KR_headers
exasgoto(labvar)
	Namep labvar;
#else
exasgoto(Namep labvar)
#endif
{
	register Addrp p;

	p = mkplace(labvar);
	if( ! ISINT(p->vtype) )
		err("assigned goto variable must be integer");
	else {
		p1_asgoto (p);
	} /* else */
}