* Copyright (c) 1980 Regents of the University of California.
* All rights reserved. The Berkeley software License Agreement
* specifies the terms and conditions for redistribution.
static char sccsid
[] = "@(#)exec.c 5.2 (Berkeley) 6/7/85";
* Routines for handling the semantics of control structures.
* University of Utah CS Dept modification history:
* Revision 2.3 85/03/18 08:03:31 donn
* Hacks for conversions from type address to numeric type -- prevent addresses
* from being stored in shorts and prevent warnings about implicit conversions.
* Revision 2.2 84/09/03 23:18:30 donn
* When a DO loop had the same variable as its loop variable and its limit,
* the limit temporary was assigned to AFTER the original value of the variable
* was destroyed by assigning the initial value to the loop variable. I
* swapped the operands of a comparison and changed the direction of the
* operator... This only affected programs when optimizing. (This may not
* be enough if something alters the order of evaluation of side effects
* Revision 2.1 84/07/19 12:02:53 donn
* Changed comment headers for UofU.
* Revision 1.3 84/07/12 18:35:12 donn
* Added change to enddo() to detect open 'if' blocks at the ends of loops.
* Revision 1.2 84/06/08 11:22:53 donn
* Fixed bug in exdo() -- if a loop parameter contained an instance of the loop
* variable and the optimizer was off, the loop variable got converted to
* register before the parameters were processed and so the loop parameters
* were initialized from garbage in the register instead of the memory version
ctlstack
->elselabel
= newlabel();
if( ( k
= (p
= fixtype(p
))->headblock
.vtype
) != TYLOGICAL
)
err("non-logical expression in IF statement");
optbuff (SKIFN
, p
, ctlstack
->elselabel
, 0);
putif (p
, ctlstack
->elselabel
);
if( ( k
= (p
= fixtype(p
))->headblock
.vtype
) != TYLOGICAL
)
err("non-logical expression in IF statement");
if(ctlstack
->ctltype
== CTLIF
)
if(ctlstack
->endlabel
== 0) ctlstack
->endlabel
= newlabel();
oldelse
=ctlstack
->elselabel
;
ctlstack
->elselabel
= newlabel();
optbuff (SKGOTO
, 0, ctlstack
->endlabel
, 0);
optbuff (SKLABEL
, 0, oldelse
, 0);
optbuff (SKIFN
, p
, ctlstack
->elselabel
, 0);
putgoto (ctlstack
->endlabel
);
putif (p
, ctlstack
->elselabel
);
else execerr("elseif out of place", CNULL
);
if(ctlstack
->ctltype
==CTLIF
)
if(ctlstack
->endlabel
== 0)
ctlstack
->endlabel
= newlabel();
ctlstack
->ctltype
= CTLELSE
;
optbuff (SKGOTO
, 0, ctlstack
->endlabel
, 0);
optbuff (SKLABEL
, 0, ctlstack
->elselabel
, 0);
putgoto (ctlstack
->endlabel
);
putlabel (ctlstack
->elselabel
);
else execerr("else out of place", CNULL
);
if (ctlstack
->ctltype
== CTLIF
)
optbuff (SKLABEL
, 0, ctlstack
->elselabel
, 0);
optbuff (SKLABEL
, 0, ctlstack
->endlabel
, 0);
putlabel (ctlstack
->elselabel
);
putlabel (ctlstack
->endlabel
);
else if (ctlstack
->ctltype
== CTLELSE
)
optbuff (SKLABEL
, 0, ctlstack
->endlabel
, 0);
putlabel (ctlstack
->endlabel
);
execerr("endif out of place", CNULL
);
/* fprintf(diagfile,"old blklevel %d \n",blklevel); dmpframe(ctlstack); */
if(++ctlstack
>= lastctl
)
many("loops or if-then-elses", 'c');
ctlstack
->ctltype
= code
;
ctlstack
->ctlabels
[i
] = 0;
fatal("control stack empty");
register struct Labelblock
*lp
;
for(lp
= labeltab
; lp
< highlabtab
; ++lp
)
/* mark all labels in inner blocks unreachable */
if(lp
->blklevel
> blklevel
)
else if(lp
->blklevel
> blklevel
)
/* move all labels referred to in inner blocks out a level */
optbuff (SKGOTO
, 0, lab
->labelno
, 0);
register struct Primblock
*lp
;
err("assignment to a non-variable");
else if(lp
->namep
->vclass
!=CLVAR
&& lp
->argsp
)
err("assignment to an undimemsioned array");
if (np
->vclass
== CLPROC
&& np
->vprocclass
== PTHISPROC
err("assignment to a subroutine name");
optbuff (SKEQ
, mkexpr(OPASSIGN
, mklhs(lp
), fixtype(rp
)), 0, 0);
puteq (mklhs(lp
), fixtype(rp
));
register struct Primblock
*p
;
if(np
->vclass
== CLUNKNOWN
)
dclerr("redeclaration of statement function", np
);
np
->vprocclass
= PSTFUNCT
;
args
= (lp
->argsp
? lp
->argsp
->listp
: CHNULL
);
np
->varxptr
.vstfdesc
= mkchain(args
, rp
);
for( ; args
; args
= args
->nextp
)
if( args
->datap
->tag
!=TPRIM
||
(p
= (struct Primblock
*) (args
->datap
) )->argsp
||
err("non-variable argument in statement function definition");
args
->datap
= (tagptr
) (p
->namep
);
excall(name
, args
, nstars
, labels
)
struct Labelblock
*labels
[ ];
settype(name
, TYSUBR
, ENULL
);
p
= mkfunct( mkprim(name
, args
, CHNULL
) );
p
->exprblock
.vtype
= p
->exprblock
.leftp
->headblock
.vtype
= TYINT
;
optbuff (SKCMGOTO
, p
, nstars
, labels
);
putcmgo (p
, nstars
, labels
);
optbuff (SKCALL
, p
, 0, 0);
execerr("pause/stop argument must be constant", CNULL
);
else if( ISINT(p
->constblock
.vtype
) )
q
= convic(p
->constblock
.const.ci
);
p
->constblock
.const.ccp
= copyn(n
, q
);
p
->constblock
.vtype
= TYCHAR
;
p
->constblock
.vleng
= (expptr
) ICON(n
);
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
);
optbuff ((stop
? SKSTOP
: SKPAUSE
), p
, 0, 0);
putexpr (call1(TYSUBR
, (stop
? "s_stop" : "s_paus"), p
));
#define CONSTINIT const[0]
#define CONSTLIMIT const[1]
#define CONSTINCR const[2]
dorange
= ctlstack
->dolabel
= range
;
np
= (Namep
) (spec
->datap
);
ctlstack
->donamep
= NULL
;
errstr("nested loops with variable %s", varstr(VL
,np
->varname
));
if( ! ONEOF(dotype
, MSKINT
|MSKREAL
) )
err("bad type on DO variable");
for(i
=0 , cp
= spec
->nextp
; cp
!=NULL
&& i
<3 ; cp
= cp
->nextp
)
p
= fixtype((expptr
) cpexpr((tagptr
) q
= cp
->datap
));
if(!ONEOF(p
->headblock
.vtype
, MSKINT
|MSKREAL
) )
err("bad type on DO parameter");
const[i
] = mkconv(dotype
, q
);
par
[i
++] = mkconv(dotype
, p
);
err("too few DO parameters");
DOINCR
= (expptr
) ICON(1);
err("too many DO parameters");
if( !optimflag
&& enregister(np
) )
/* stgp points to a storage version, varp to a register version */
ctlstack
->ctlabels
[i
] = newlabel();
ctlstack
->domax
= DOLIMIT
;
ctlstack
->domax
= (expptr
) mktemp(dotype
, PNULL
);
ctlstack
->dostep
= DOINCR
;
if( (incsign
= conssgn(CONSTINCR
)) == 0)
err("zero DO increment");
ctlstack
->dostepsign
= (incsign
> 0 ? POSSTEP
: NEGSTEP
);
ctlstack
->dostep
= (expptr
) mktemp(dotype
, PNULL
);
ctlstack
->dostepsign
= VARSTEP
;
doslot
= optbuff (SKDOHEAD
,0,0,ctlstack
);
if( CONSTLIMIT
&& CONSTINIT
&& ctlstack
->dostepsign
!=VARSTEP
)
optbuff (SKEQ
,mkexpr(OPASSIGN
,cpexpr(dovarp
),cpexpr(DOINIT
)),
puteq (cpexpr(dovarp
), cpexpr(DOINIT
));
q
= mkexpr(OPMINUS
, cpexpr(CONSTLIMIT
), cpexpr(CONSTINIT
));
if((incsign
* conssgn(q
)) == -1)
warn("DO range never executed");
optbuff (SKGOTO
,0,ctlstack
->endlabel
,0);
putgoto (ctlstack
->endlabel
);
else if (ctlstack
->dostepsign
!= VARSTEP
&& !onetripflag
)
q
= (expptr
) cpexpr(ctlstack
->domax
);
q
= mkexpr(OPASSIGN
, cpexpr(ctlstack
->domax
), DOLIMIT
);
q1
= mkexpr(OPASSIGN
, cpexpr(dovarp
), DOINIT
);
q
= mkexpr( (ctlstack
->dostepsign
== POSSTEP
? OPGE
: OPLE
),
optbuff (SKIFN
,q
, ctlstack
->endlabel
,0);
putif (q
, ctlstack
->endlabel
);
mkexpr(OPASSIGN
,cpexpr(ctlstack
->domax
),DOLIMIT
),0,0);
puteq (cpexpr(ctlstack
->domax
), DOLIMIT
);
mkexpr(OPASSIGN
, cpexpr(ctlstack
->dostep
),
optbuff (SKEQ
,mkexpr(OPASSIGN
,cpexpr(dovarp
), q
),0,0);
puteq (cpexpr(dovarp
), q
);
if (onetripflag
&& ctlstack
->dostepsign
== VARSTEP
)
mkexpr(OPASSIGN
,cpexpr(ctlstack
->dostep
),DOINCR
),0,0);
puteq (cpexpr(ctlstack
->dostep
), DOINCR
);
if (ctlstack
->dostepsign
== VARSTEP
)
optbuff (SKGOTO
,0,ctlstack
->dobodylabel
,0);
putgoto (ctlstack
->dobodylabel
);
optbuff (SKIFN
,mkexpr(OPGE
, cpexpr(ctlstack
->dostep
), ICON(0)),
putif (mkexpr(OPGE
, cpexpr(ctlstack
->dostep
), ICON(0)),
optbuff (SKLABEL
,0,ctlstack
->doposlabel
,0);
putlabel (ctlstack
->doposlabel
);
incr
= mkexpr(OPPLUSEQ
, cpexpr(dovarp
), cpexpr(ctlstack
->dostep
));
test
= mkexpr(OPLE
, incr
, cpexpr(ctlstack
->domax
));
optbuff (SKIFN
,test
, ctlstack
->endlabel
,0);
putif (test
, ctlstack
->endlabel
);
optbuff (SKLABEL
,0,ctlstack
->dobodylabel
,0);
putlabel (ctlstack
->dobodylabel
);
optbuff (SKEQ
,mkexpr(OPASSIGN
,dostgp
, dovarp
),0,0);
doslot
->nullslot
= optbuff (SKNULL
,0,0,0);
register struct Ctlframe
*q
;
while (ctlstack
->ctltype
== CTLIF
|| ctlstack
->ctltype
== CTLELSE
)
execerr("missing endif", CNULL
);
if (np
= ctlstack
->donamep
)
t
= mkexpr(OPPLUSEQ
, cpexpr(rv
), cpexpr(ctlstack
->dostep
) );
doslot
= optbuff (SKENDDO
,0,0,ctlstack
);
if (ctlstack
->dostepsign
== VARSTEP
)
mkexpr(OPLE
, cpexpr(ctlstack
->dostep
), ICON(0)),
optbuff (SKLABEL
,0,ctlstack
->doneglabel
,0);
optbuff (SKIFN
,mkexpr(OPLT
, t
, ctlstack
->domax
),
ctlstack
->dobodylabel
,0);
putif (mkexpr(OPLE
, cpexpr(ctlstack
->dostep
), ICON(0)),
putlabel (ctlstack
->doneglabel
);
putif (mkexpr(OPLT
, t
, ctlstack
->domax
),
op
= (ctlstack
->dostepsign
== POSSTEP
? OPGT
: OPLT
);
optbuff (SKIFN
, mkexpr(op
,t
,ctlstack
->domax
),
ctlstack
->dobodylabel
,0);
putif (mkexpr(op
, t
, ctlstack
->domax
),
optbuff (SKLABEL
,0,ctlstack
->endlabel
,0);
putlabel (ctlstack
->endlabel
);
optbuff (SKEQ
,mkexpr(OPASSIGN
,ap
, rv
),0,0);
ctlstack
->ctlabels
[i
] = 0;
deregister(ctlstack
->donamep
);
ctlstack
->donamep
->vdovar
= NO
;
doslot
->nullslot
= optbuff (SKNULL
,0,0,0);
for (q
= ctlstack
; q
>= ctls
; --q
)
exassign(vname
, labelval
)
struct Labelblock
*labelval
;
if( p
->vtype
== TYSHORT
)
err("insufficient precision in ASSIGN variable");
if( ! ONEOF(p
->vtype
, MSKINT
|MSKADDR
) )
err("noninteger assign variable");
optbuff (SKASSIGN
, p
, labelval
->labelno
, 0);
puteq (p
, intrconv(p
->vtype
, mkaddcon(labelval
->labelno
)));
exarif(expr
, neglab
, zerlab
, poslab
)
struct Labelblock
*neglab
, *zerlab
, *poslab
;
struct Labelblock
*labels
[3];
if( ! ONEOF(expr
->headblock
.vtype
, MSKINT
|MSKREAL
) )
err("invalid type of arithmetic if expression");
exar2(OPLE
, expr
, lm
, lp
);
exar2(OPNE
, expr
, lm
, lz
);
exar2(OPGE
, expr
, lz
, lm
);
optbuff (SKARIF
, expr
, 0, labels
);
prarif(expr
, lm
, lz
, lp
);
LOCAL
exar2 (op
, e
, l1
, l2
)
optbuff (SKIFN
, mkexpr(op
, e
, ICON(0)), l2
, 0);
optbuff (SKGOTO
, 0, l1
, 0);
putif (mkexpr(op
, e
, ICON(0)), l2
);
warn("RETURN statement in main or block data");
if(p
&& (proctype
!=TYSUBR
|| procclass
!=CLPROC
) )
err("alternate return in nonsubroutine");
optbuff (SKRETURN
, p
, retlabel
, 0);
(proctype
==TYSUBR
? ret0label
: retlabel
), 0);
putgoto (proctype
==TYSUBR
? ret0label
: retlabel
);
struct Hashentry
*labvar
;
err("assigned goto variable must be integer");
optbuff (SKASGOTO
, p
, 0, 0);