Added
This commit is contained in:
ceriel
831
lang/fortran/comp/exec.c
Normal file
831
lang/fortran/comp/exec.c
Normal file
@@ -0,0 +1,831 @@
|
||||
/****************************************************************
|
||||
Copyright 1990 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 "p1defs.h"
|
||||
#include "names.h"
|
||||
|
||||
LOCAL void exar2(), popctl(), pushctl();
|
||||
|
||||
/* Logical IF codes
|
||||
*/
|
||||
|
||||
|
||||
exif(p)
|
||||
expptr p;
|
||||
{
|
||||
pushctl(CTLIF);
|
||||
putif(p, 0); /* 0 => if, not elseif */
|
||||
}
|
||||
|
||||
|
||||
|
||||
exelif(p)
|
||||
expptr p;
|
||||
{
|
||||
if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
|
||||
putif(p, 1); /* 1 ==> elseif */
|
||||
else
|
||||
execerr("elseif out of place", CNULL);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
exelse()
|
||||
{
|
||||
register struct Ctlframe *c;
|
||||
|
||||
for(c = ctlstack; c->ctltype == CTLIFX; --c);
|
||||
if(c->ctltype == CTLIF) {
|
||||
p1_else ();
|
||||
c->ctltype = CTLELSE;
|
||||
}
|
||||
else
|
||||
execerr("else out of place", CNULL);
|
||||
}
|
||||
|
||||
|
||||
exendif()
|
||||
{
|
||||
while(ctlstack->ctltype == CTLIFX) {
|
||||
popctl();
|
||||
p1else_end();
|
||||
}
|
||||
if(ctlstack->ctltype == CTLIF) {
|
||||
popctl();
|
||||
p1_endif ();
|
||||
}
|
||||
else if(ctlstack->ctltype == CTLELSE) {
|
||||
popctl();
|
||||
p1else_end ();
|
||||
}
|
||||
else
|
||||
execerr("endif out of place", CNULL);
|
||||
}
|
||||
|
||||
|
||||
new_endif()
|
||||
{
|
||||
if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
|
||||
pushctl(CTLIFX);
|
||||
else
|
||||
err("new_endif bug");
|
||||
}
|
||||
|
||||
/* pushctl -- Start a new control construct, initialize the labels (to
|
||||
zero) */
|
||||
|
||||
LOCAL void
|
||||
pushctl(code)
|
||||
int code;
|
||||
{
|
||||
register int i;
|
||||
|
||||
if(++ctlstack >= lastctl)
|
||||
many("loops or if-then-elses", 'c', maxctl);
|
||||
ctlstack->ctltype = code;
|
||||
for(i = 0 ; i < 4 ; ++i)
|
||||
ctlstack->ctlabels[i] = 0;
|
||||
ctlstack->dowhile = 0;
|
||||
++blklevel;
|
||||
}
|
||||
|
||||
|
||||
LOCAL void
|
||||
popctl()
|
||||
{
|
||||
if( ctlstack-- < ctls )
|
||||
Fatal("control stack empty");
|
||||
--blklevel;
|
||||
}
|
||||
|
||||
|
||||
|
||||
/* poplab -- update the flags in labeltab */
|
||||
|
||||
LOCAL poplab()
|
||||
{
|
||||
register struct Labelblock *lp;
|
||||
|
||||
for(lp = labeltab ; lp < highlabtab ; ++lp)
|
||||
if(lp->labdefined)
|
||||
{
|
||||
/* mark all labels in inner blocks unreachable */
|
||||
if(lp->blklevel > blklevel)
|
||||
lp->labinacc = YES;
|
||||
}
|
||||
else if(lp->blklevel > blklevel)
|
||||
{
|
||||
/* move all labels referred to in inner blocks out a level */
|
||||
lp->blklevel = blklevel;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/* BRANCHING CODE
|
||||
*/
|
||||
|
||||
exgoto(lab)
|
||||
struct Labelblock *lab;
|
||||
{
|
||||
lab->labused = 1;
|
||||
p1_goto (lab -> stateno);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
exequals(lp, rp)
|
||||
register struct Primblock *lp;
|
||||
register expptr rp;
|
||||
{
|
||||
if(lp->tag != TPRIM)
|
||||
{
|
||||
err("assignment to a non-variable");
|
||||
frexpr((expptr)lp);
|
||||
frexpr(rp);
|
||||
}
|
||||
else if(lp->namep->vclass!=CLVAR && lp->argsp)
|
||||
{
|
||||
if(parstate >= INEXEC)
|
||||
err("statement function amid executables");
|
||||
mkstfunct(lp, rp);
|
||||
}
|
||||
else
|
||||
{
|
||||
expptr new_lp, new_rp;
|
||||
|
||||
if(parstate < INDATA)
|
||||
enddcl();
|
||||
new_lp = mklhs (lp);
|
||||
new_rp = fixtype (rp);
|
||||
puteq(new_lp, new_rp);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
/* Make Statement Function */
|
||||
|
||||
long laststfcn = -1, thisstno;
|
||||
int doing_stmtfcn;
|
||||
|
||||
mkstfunct(lp, rp)
|
||||
struct Primblock *lp;
|
||||
expptr rp;
|
||||
{
|
||||
register struct Primblock *p;
|
||||
register Namep np;
|
||||
chainp args;
|
||||
|
||||
laststfcn = thisstno;
|
||||
np = lp->namep;
|
||||
if(np->vclass == CLUNKNOWN)
|
||||
np->vclass = CLPROC;
|
||||
else
|
||||
{
|
||||
dclerr("redeclaration of statement function", np);
|
||||
return;
|
||||
}
|
||||
np->vprocclass = PSTFUNCT;
|
||||
np->vstg = STGSTFUNCT;
|
||||
|
||||
/* Set the type of the function */
|
||||
|
||||
impldcl(np);
|
||||
if (np->vtype == TYCHAR && !np->vleng)
|
||||
err("character statement function with length (*)");
|
||||
args = (lp->argsp ? lp->argsp->listp : CHNULL);
|
||||
np->varxptr.vstfdesc = mkchain((char *)args, (chainp)rp);
|
||||
|
||||
for(doing_stmtfcn = 1 ; args ; args = args->nextp)
|
||||
|
||||
/* It is an error for the formal parameters to have arguments or
|
||||
subscripts */
|
||||
|
||||
if( ((tagptr)(args->datap))->tag!=TPRIM ||
|
||||
(p = (struct Primblock *)(args->datap) )->argsp ||
|
||||
p->fcharp || p->lcharp )
|
||||
err("non-variable argument in statement function definition");
|
||||
else
|
||||
{
|
||||
|
||||
/* Replace the name on the left-hand side */
|
||||
|
||||
args->datap = (char *)p->namep;
|
||||
vardcl(p -> namep);
|
||||
free((char *)p);
|
||||
}
|
||||
doing_stmtfcn = 0;
|
||||
}
|
||||
|
||||
static void
|
||||
mixed_type(np)
|
||||
Namep np;
|
||||
{
|
||||
char buf[128];
|
||||
sprintf(buf, "%s function %.90s invoked as subroutine",
|
||||
ftn_types[np->vtype], np->fvarname);
|
||||
warn(buf);
|
||||
}
|
||||
|
||||
|
||||
excall(name, args, nstars, labels)
|
||||
Namep name;
|
||||
struct Listblock *args;
|
||||
int nstars;
|
||||
struct Labelblock *labels[ ];
|
||||
{
|
||||
register expptr p;
|
||||
|
||||
if (name->vtype != TYSUBR) {
|
||||
if (name->vinfproc && !name->vcalled) {
|
||||
name->vtype = TYSUBR;
|
||||
frexpr(name->vleng);
|
||||
name->vleng = 0;
|
||||
}
|
||||
else if (!name->vimpltype && name->vtype != TYUNKNOWN)
|
||||
mixed_type(name);
|
||||
else
|
||||
settype(name, TYSUBR, (ftnint)0);
|
||||
}
|
||||
p = mkfunct( mkprim(name, args, CHNULL) );
|
||||
|
||||
/* Subroutines and their identifiers acquire the type INT */
|
||||
|
||||
p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
|
||||
|
||||
/* Handle the alternate return mechanism */
|
||||
|
||||
if(nstars > 0)
|
||||
putcmgo(putx(fixtype(p)), nstars, labels);
|
||||
else
|
||||
putexpr(p);
|
||||
}
|
||||
|
||||
|
||||
|
||||
exstop(stop, p)
|
||||
int stop;
|
||||
register expptr p;
|
||||
{
|
||||
char *str;
|
||||
int n;
|
||||
expptr mkstrcon();
|
||||
|
||||
if(p)
|
||||
{
|
||||
if( ! ISCONST(p) )
|
||||
{
|
||||
execerr("pause/stop argument must be constant", CNULL);
|
||||
frexpr(p);
|
||||
p = mkstrcon(0, CNULL);
|
||||
}
|
||||
else if( ISINT(p->constblock.vtype) )
|
||||
{
|
||||
str = convic(p->constblock.Const.ci);
|
||||
n = strlen(str);
|
||||
if(n > 0)
|
||||
{
|
||||
p->constblock.Const.ccp = copyn(n, str);
|
||||
p->constblock.Const.ccp1.blanks = 0;
|
||||
p->constblock.vtype = TYCHAR;
|
||||
p->constblock.vleng = (expptr) ICON(n);
|
||||
}
|
||||
else
|
||||
p = (expptr) mkstrcon(0, CNULL);
|
||||
}
|
||||
else if(p->constblock.vtype != TYCHAR)
|
||||
{
|
||||
execerr("pause/stop argument must be integer or string", CNULL);
|
||||
p = (expptr) mkstrcon(0, CNULL);
|
||||
}
|
||||
}
|
||||
else p = (expptr) mkstrcon(0, CNULL);
|
||||
|
||||
{
|
||||
expptr subr_call;
|
||||
|
||||
subr_call = call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p);
|
||||
putexpr( subr_call );
|
||||
}
|
||||
}
|
||||
|
||||
/* DO LOOP CODE */
|
||||
|
||||
#define DOINIT par[0]
|
||||
#define DOLIMIT par[1]
|
||||
#define DOINCR par[2]
|
||||
|
||||
|
||||
/* Macros for ctlstack -> dostepsign */
|
||||
|
||||
#define VARSTEP 0
|
||||
#define POSSTEP 1
|
||||
#define NEGSTEP 2
|
||||
|
||||
|
||||
/* exdo -- generate DO loop code. In the case of a variable increment,
|
||||
positive increment tests are placed above the body, negative increment
|
||||
tests are placed below (see enddo() ) */
|
||||
|
||||
exdo(range, loopname, spec)
|
||||
int range; /* end label */
|
||||
Namep loopname;
|
||||
chainp spec; /* input spec must have at least 2 exprs */
|
||||
{
|
||||
register expptr p;
|
||||
register Namep np;
|
||||
chainp cp; /* loops over the fields in spec */
|
||||
register int i;
|
||||
int dotype; /* type of the index variable */
|
||||
int incsign; /* sign of the increment, if it's constant
|
||||
*/
|
||||
Addrp dovarp; /* loop index variable */
|
||||
expptr doinit; /* constant or register for init param */
|
||||
expptr par[3]; /* local specification parameters */
|
||||
|
||||
expptr init, test, inc; /* Expressions in the resulting FOR loop */
|
||||
|
||||
|
||||
test = ENULL;
|
||||
|
||||
pushctl(CTLDO);
|
||||
dorange = ctlstack->dolabel = range;
|
||||
ctlstack->loopname = loopname;
|
||||
|
||||
/* Declare the loop index */
|
||||
|
||||
np = (Namep)spec->datap;
|
||||
ctlstack->donamep = NULL;
|
||||
if (!np) { /* do while */
|
||||
ctlstack->dowhile = 1;
|
||||
#if 0
|
||||
if (loopname) {
|
||||
if (loopname->vtype == TYUNKNOWN) {
|
||||
loopname->vdcldone = 1;
|
||||
loopname->vclass = CLLABEL;
|
||||
loopname->vprocclass = PLABEL;
|
||||
loopname->vtype = TYLABEL;
|
||||
}
|
||||
if (loopname->vtype == TYLABEL)
|
||||
if (loopname->vdovar)
|
||||
dclerr("already in use as a loop name",
|
||||
loopname);
|
||||
else
|
||||
loopname->vdovar = 1;
|
||||
else
|
||||
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);
|
||||
}
|
||||
|
||||
exenddo(np)
|
||||
Namep np;
|
||||
{
|
||||
Namep np1;
|
||||
int here;
|
||||
struct Ctlframe *cf;
|
||||
|
||||
if( ctlstack < ctls )
|
||||
Fatal("control stack empty");
|
||||
here = ctlstack->dolabel;
|
||||
if (ctlstack->ctltype != CTLDO || here >= 0) {
|
||||
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);
|
||||
}
|
||||
|
||||
|
||||
enddo(here)
|
||||
int here;
|
||||
{
|
||||
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;
|
||||
e = ctlstack->dostep;
|
||||
if (e->tag == TADDR && e->addrblock.istemp)
|
||||
frtemp((Addrp)e);
|
||||
else
|
||||
frexpr(e);
|
||||
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;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
exassign(vname, labelval)
|
||||
register Namep vname;
|
||||
struct Labelblock *labelval;
|
||||
{
|
||||
Addrp p;
|
||||
expptr mkaddcon();
|
||||
register Addrp q;
|
||||
static char nullstr[] = "";
|
||||
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 */
|
||||
|
||||
if (!labelval->labdefined || !labelval->fmtstring) {
|
||||
|
||||
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... */
|
||||
|
||||
fs = labelval->fmtstring;
|
||||
if (!labelval->labdefined || fs && fs != nullstr) {
|
||||
extern void fmtname();
|
||||
|
||||
if (!fs)
|
||||
labelval->fmtstring = nullstr;
|
||||
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 */
|
||||
|
||||
|
||||
|
||||
exarif(expr, neglab, zerlab, poslab)
|
||||
expptr expr;
|
||||
struct Labelblock *neglab, *zerlab, *poslab;
|
||||
{
|
||||
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
|
||||
exar2(op, e, l1, l2)
|
||||
int op;
|
||||
expptr e;
|
||||
struct Labelblock *l1, *l2;
|
||||
{
|
||||
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 */
|
||||
|
||||
exreturn(p)
|
||||
register expptr p;
|
||||
{
|
||||
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);
|
||||
}
|
||||
|
||||
|
||||
exasgoto(labvar)
|
||||
Namep labvar;
|
||||
{
|
||||
register Addrp p;
|
||||
void p1_asgoto();
|
||||
|
||||
p = mkplace(labvar);
|
||||
if( ! ISINT(p->vtype) )
|
||||
err("assigned goto variable must be integer");
|
||||
else {
|
||||
p1_asgoto (p);
|
||||
} /* else */
|
||||
}
|
||||
Reference in New Issue
Block a user