[unix-history] / usr / src / cmd / f77 / exec.c

#include "defs"

/*   Logical IF codes
*/


exif(p)
expptr p;
{
pushctl(CTLIF);
ctlstack->elselabel = newlabel();
putif(p, ctlstack->elselabel);
}


exelif(p)
expptr p;
{
if(ctlstack->ctltype == CTLIF)
	{
	if(ctlstack->endlabel == 0)
		ctlstack->endlabel = newlabel();
	putgoto(ctlstack->endlabel);
	putlabel(ctlstack->elselabel);
	ctlstack->elselabel = newlabel();
	putif(p, ctlstack->elselabel);
	}

else	execerr("elseif out of place", CNULL);
}


exelse()
{
if(ctlstack->ctltype==CTLIF)
	{
	if(ctlstack->endlabel == 0)
		ctlstack->endlabel = newlabel();
	putgoto( ctlstack->endlabel );
	putlabel(ctlstack->elselabel);
	ctlstack->ctltype = CTLELSE;
	}

else	execerr("else out of place", CNULL);
}


exendif()
{
if(ctlstack->ctltype == CTLIF)
	{
	putlabel(ctlstack->elselabel);
	if(ctlstack->endlabel)
		putlabel(ctlstack->endlabel);
	popctl();
	}
else if(ctlstack->ctltype == CTLELSE)
	{
	putlabel(ctlstack->endlabel);
	popctl();
	}

else
	execerr("endif out of place", CNULL);
}


LOCAL pushctl(code)
int code;
{
register int i;

if(++ctlstack >= lastctl)
	many("loops or if-then-elses", 'c');
ctlstack->ctltype = code;
for(i = 0 ; i < 4 ; ++i)
	ctlstack->ctlabels[i] = 0;
++blklevel;
}


LOCAL popctl()
{
if( ctlstack-- < ctls )
	fatal("control stack empty");
--blklevel;
}


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;
		}
}
\f


/*  BRANCHING CODE
*/

exgoto(lab)
struct Labelblock *lab;
{
putgoto(lab->labelno);
}


exequals(lp, rp)
register struct Primblock *lp;
register expptr rp;
{
if(lp->tag != TPRIM)
	{
	err("assignment to a non-variable");
	frexpr(lp);
	frexpr(rp);
	}
else if(lp->namep->vclass!=CLVAR && lp->argsp)
	{
	if(parstate >= INEXEC)
		err("statement function amid executables");
	else
		mkstfunct(lp, rp);
	}
else
	{
	if(parstate < INDATA)
		enddcl();
	puteq(mklhs(lp), fixtype(rp));
	}
}


mkstfunct(lp, rp)
struct Primblock *lp;
expptr rp;
{
register struct Primblock *p;
register Namep np;
chainp args;

np = lp->namep;
if(np->vclass == CLUNKNOWN)
	np->vclass = CLPROC;
else
	{
	dclerr("redeclaration of statement function", np);
	return;
	}
np->vprocclass = PSTFUNCT;
np->vstg = STGSTFUNCT;
impldcl(np);
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 ||
		p->fcharp || p->lcharp )
		err("non-variable argument in statement function definition");
	else
		{
		args->datap = (tagptr) (p->namep);
		vardcl(p->namep);
		free(p);
		}
}


excall(name, args, nstars, labels)
Namep name;
struct Listblock *args;
int nstars;
struct Labelblock *labels[ ];
{
register expptr p;

settype(name, TYSUBR, ENULL);
p = mkfunct( mkprim(name, args, CHNULL) );
p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
if(nstars > 0)
	putcmgo(p, nstars, labels);
else putexpr(p);
}


exstop(stop, p)
int stop;
register expptr p;
{
char *q;
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) )
		{
		q = convic(p->constblock.const.ci);
		n = strlen(q);
		if(n > 0)
			{
			p->constblock.const.ccp = copyn(n, q);
			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);

putexpr( call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p) );
}
\f
/* DO LOOP CODE */

#define DOINIT	par[0]
#define DOLIMIT	par[1]
#define DOINCR	par[2]

#define VARSTEP	0
#define POSSTEP	1
#define NEGSTEP	2


exdo(range, spec)
int range;
chainp spec;
{
register expptr p, q;
expptr q1;
register Namep np;
chainp cp;
register int i;
int dotype, incsign;
Addrp dovarp, dostgp;
expptr par[3];

pushctl(CTLDO);
dorange = ctlstack->dolabel = range;
np = (Namep) (spec->datap);
ctlstack->donamep = NULL;
if(np->vdovar)
	{
	errstr("nested loops with variable %s", varstr(VL,np->varname));
	ctlstack->donamep = NULL;
	return;
	}

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

np->vdovar = YES;
if( enregister(np) )
	{
	/* stgp points to a storage version, varp to a register version */
	dostgp = dovarp;
	dovarp = mkplace(np);
	}
else
	dostgp = NULL;
dotype = dovarp->vtype;

for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
	{
	p = par[i++] = fixtype(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;
	}

ctlstack->endlabel = newlabel();
ctlstack->dobodylabel = newlabel();

if( ISCONST(DOLIMIT) )
	ctlstack->domax = mkconv(dotype, DOLIMIT);
else
	ctlstack->domax = (expptr) mktemp(dotype, PNULL);

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) mktemp(dotype, PNULL);
	ctlstack->dostepsign = VARSTEP;
	ctlstack->doposlabel = newlabel();
	ctlstack->doneglabel = newlabel();
	}

if( ISCONST(ctlstack->domax) && ISCONST(DOINIT) && ctlstack->dostepsign!=VARSTEP)
	{
	puteq(cpexpr(dovarp), cpexpr(DOINIT));
	if( onetripflag )
		frexpr(DOINIT);
	else
		{
		q = mkexpr(OPPLUS, ICON(1),
			mkexpr(OPMINUS, cpexpr(ctlstack->domax), cpexpr(DOINIT)) );
		if(incsign != conssgn(q))
			{
			warn("DO range never executed");
			putgoto(ctlstack->endlabel);
			}
		frexpr(q);
		}
	}
else if(ctlstack->dostepsign!=VARSTEP && !onetripflag)
	{
	if( ISCONST(ctlstack->domax) )
		q = (expptr) cpexpr(ctlstack->domax);
	else
		q = mkexpr(OPASSIGN, cpexpr(ctlstack->domax), DOLIMIT);

	q1 = mkexpr(OPASSIGN, cpexpr(dovarp), DOINIT);
	q = mkexpr( (ctlstack->dostepsign==POSSTEP ? OPLE : OPGE), q1, q);
	putif(q, ctlstack->endlabel);
	}
else
	{
	if(! ISCONST(ctlstack->domax) )
		puteq( cpexpr(ctlstack->domax), DOLIMIT);
	q = DOINIT;
	if( ! onetripflag )
		q = mkexpr(OPMINUS, q,
			mkexpr(OPASSIGN, cpexpr(ctlstack->dostep), DOINCR) );
	puteq( cpexpr(dovarp), q);
	if(onetripflag && ctlstack->dostepsign==VARSTEP)
		puteq( cpexpr(ctlstack->dostep), DOINCR);
	}

if(ctlstack->dostepsign == VARSTEP)
	{
	if(onetripflag)
		putgoto(ctlstack->dobodylabel);
	else
		putif( mkexpr(OPGE, cpexpr(ctlstack->dostep), ICON(0)),
			ctlstack->doneglabel );
	putlabel(ctlstack->doposlabel);
	putif( mkexpr(OPLE,
		mkexpr(OPPLUSEQ, cpexpr(dovarp), cpexpr(ctlstack->dostep)),
		cpexpr(ctlstack->domax) ),
			ctlstack->endlabel);
	}
putlabel(ctlstack->dobodylabel);
if(dostgp)
	puteq(dostgp, cpexpr(dovarp));
frexpr(dovarp);
}


enddo(here)
int here;
{
register struct Ctlframe *q;
register expptr t;
Namep np;
Addrp ap;
register int i;

while(here == dorange)
	{
	if(np = ctlstack->donamep)
		{
		t = mkexpr(OPPLUSEQ, mkplace(ctlstack->donamep),
			cpexpr(ctlstack->dostep) );
	
		if(ctlstack->dostepsign == VARSTEP)
			{
			putif( mkexpr(OPLE, cpexpr(ctlstack->dostep), ICON(0)), ctlstack->doposlabel);
			putlabel(ctlstack->doneglabel);
			putif( mkexpr(OPLT, t, ctlstack->domax), ctlstack->dobodylabel);
			}
		else
			putif( mkexpr( (ctlstack->dostepsign==POSSTEP ? OPGT : OPLT),
				t, ctlstack->domax),
				ctlstack->dobodylabel);
		putlabel(ctlstack->endlabel);
		if(ap = memversion(np))
			puteq(ap, mkplace(np));
		for(i = 0 ; i < 4 ; ++i)
			ctlstack->ctlabels[i] = 0;
		deregister(ctlstack->donamep);
		ctlstack->donamep->vdovar = NO;
		frexpr(ctlstack->dostep);
		}

	popctl();
	poplab();
	dorange = 0;
	for(q = ctlstack ; q>=ctls ; --q)
		if(q->ctltype == CTLDO)
			{
			dorange = q->dolabel;
			break;
			}
	}
}
\f
exassign(vname, labelval)
Namep vname;
struct Labelblock *labelval;
{
Addrp p;
expptr mkaddcon();

p = mkplace(vname);
if( ! ONEOF(p->vtype, MSKINT|MSKADDR) )
	err("noninteger assign variable");
else
	puteq(p, mkaddcon(labelval->labelno) );
}


exarif(expr, neglab, zerlab, poslab)
expptr expr;
struct Labelblock *neglab, *zerlab, *poslab;
{
register int lm, lz, lp;

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

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


LOCAL exar2(op, e, l1, l2)
int op;
expptr e;
int l1, l2;
{
putif( mkexpr(op, e, ICON(0)), l2);
putgoto(l1);
}


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)
	{
	putforce(TYINT, p);
	putgoto(retlabel);
	}
else
	putgoto(proctype==TYSUBR ? ret0label : retlabel);
}


exasgoto(labvar)
struct Hashentry *labvar;
{
register Addrp p;

p = mkplace(labvar);
if( ! ISINT(p->vtype) )
	err("assigned goto variable must be integer");
else
	putbranch(p);
}
Commit	Line	Data
853979d9 BJ	1	#include "defs"
	2
	3	/* Logical IF codes
	4	*/
	5
	6
	7	exif(p)
	8	expptr p;
	9	{
	10	pushctl(CTLIF);
	11	ctlstack->elselabel = newlabel();
	12	putif(p, ctlstack->elselabel);
	13	}
	14
	15
	16
	17	exelif(p)
	18	expptr p;
	19	{
	20	if(ctlstack->ctltype == CTLIF)
	21	{
	22	if(ctlstack->endlabel == 0)
	23	ctlstack->endlabel = newlabel();
	24	putgoto(ctlstack->endlabel);
	25	putlabel(ctlstack->elselabel);
	26	ctlstack->elselabel = newlabel();
	27	putif(p, ctlstack->elselabel);
	28	}
	29
	30	else execerr("elseif out of place", CNULL);
	31	}
	32
	33
	34
	35
	36
	37	exelse()
	38	{
	39	if(ctlstack->ctltype==CTLIF)
	40	{
	41	if(ctlstack->endlabel == 0)
	42	ctlstack->endlabel = newlabel();
	43	putgoto( ctlstack->endlabel );
	44	putlabel(ctlstack->elselabel);
	45	ctlstack->ctltype = CTLELSE;
	46	}
	47
	48	else execerr("else out of place", CNULL);
	49	}
	50
	51
	52	exendif()
	53	{
	54	if(ctlstack->ctltype == CTLIF)
	55	{
	56	putlabel(ctlstack->elselabel);
	57	if(ctlstack->endlabel)
	58	putlabel(ctlstack->endlabel);
	59	popctl();
	60	}
	61	else if(ctlstack->ctltype == CTLELSE)
	62	{
	63	putlabel(ctlstack->endlabel);
	64	popctl();
65	}
66
67	else
68	execerr("endif out of place", CNULL);
69	}
70
71
72
73	LOCAL pushctl(code)
74	int code;
75	{
76	register int i;
77
78	if(++ctlstack >= lastctl)
79	many("loops or if-then-elses", 'c');
80	ctlstack->ctltype = code;
81	for(i = 0 ; i < 4 ; ++i)
82	ctlstack->ctlabels[i] = 0;
83	++blklevel;
84	}
85
86
87	LOCAL popctl()
88	{
89	if( ctlstack-- < ctls )
90	fatal("control stack empty");
91	--blklevel;
92	}
93
94
95
96	LOCAL poplab()
97	{
98	register struct Labelblock *lp;
99
100	for(lp = labeltab ; lp < highlabtab ; ++lp)
101	if(lp->labdefined)
102	{
103	/* mark all labels in inner blocks unreachable */
104	if(lp->blklevel > blklevel)
105	lp->labinacc = YES;
106	}
107	else if(lp->blklevel > blklevel)
108	{
109	/* move all labels referred to in inner blocks out a level */
110	lp->blklevel = blklevel;
111	}
112	}
113	\f
114
115
116	/* BRANCHING CODE
117	*/
118
119	exgoto(lab)
120	struct Labelblock *lab;
121	{
122	putgoto(lab->labelno);
123	}
124
125
126
127
128
129
130
131	exequals(lp, rp)
132	register struct Primblock *lp;
133	register expptr rp;
134	{
135	if(lp->tag != TPRIM)
136	{
137	err("assignment to a non-variable");
138	frexpr(lp);
139	frexpr(rp);
140	}
141	else if(lp->namep->vclass!=CLVAR && lp->argsp)
142	{
143	if(parstate >= INEXEC)
144	err("statement function amid executables");
145	else
146	mkstfunct(lp, rp);
147	}
148	else
149	{
150	if(parstate < INDATA)
151	enddcl();
152	puteq(mklhs(lp), fixtype(rp));
153	}
154	}
155
156
157
158	mkstfunct(lp, rp)
159	struct Primblock *lp;
160	expptr rp;
161	{
162	register struct Primblock *p;
163	register Namep np;
164	chainp args;
165
166	np = lp->namep;
167	if(np->vclass == CLUNKNOWN)
168	np->vclass = CLPROC;
169	else
170	{
171	dclerr("redeclaration of statement function", np);
172	return;
173	}
174	np->vprocclass = PSTFUNCT;
175	np->vstg = STGSTFUNCT;
176	impldcl(np);
177	args = (lp->argsp ? lp->argsp->listp : CHNULL);
178	np->varxptr.vstfdesc = mkchain(args , rp );
179
180	for( ; args ; args = args->nextp)
181	if( args->datap->tag!=TPRIM \|\|
182	(p = (struct Primblock *) (args->datap) )->argsp \|\|
183	p->fcharp \|\| p->lcharp )
184	err("non-variable argument in statement function definition");
185	else
186	{
187	args->datap = (tagptr) (p->namep);
188	vardcl(p->namep);
189	free(p);
190	}
191	}
192
193
194
195	excall(name, args, nstars, labels)
196	Namep name;
197	struct Listblock *args;
198	int nstars;
199	struct Labelblock *labels[ ];
200	{
201	register expptr p;
202
203	settype(name, TYSUBR, ENULL);
204	p = mkfunct( mkprim(name, args, CHNULL) );
205	p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
206	if(nstars > 0)
207	putcmgo(p, nstars, labels);
208	else putexpr(p);
209	}
210
211
212
213	exstop(stop, p)
214	int stop;
215	register expptr p;
216	{
217	char *q;
218	int n;
219	expptr mkstrcon();
220
221	if(p)
222	{
223	if( ! ISCONST(p) )
224	{
225	execerr("pause/stop argument must be constant", CNULL);
226	frexpr(p);
227	p = mkstrcon(0, CNULL);
228	}
229	else if( ISINT(p->constblock.vtype) )
230	{
231	q = convic(p->constblock.const.ci);
232	n = strlen(q);
233	if(n > 0)
234	{
235	p->constblock.const.ccp = copyn(n, q);
236	p->constblock.vtype = TYCHAR;
237	p->constblock.vleng = (expptr) ICON(n);
238	}
239	else
240	p = (expptr) mkstrcon(0, CNULL);
241	}
242	else if(p->constblock.vtype != TYCHAR)
243	{
244	execerr("pause/stop argument must be integer or string", CNULL);
245	p = (expptr) mkstrcon(0, CNULL);
246	}
247	}
248	else p = (expptr) mkstrcon(0, CNULL);
249
250	putexpr( call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p) );
251	}
252	\f
253	/* DO LOOP CODE */
254
255	#define DOINIT par[0]
256	#define DOLIMIT par[1]
257	#define DOINCR par[2]
258
259	#define VARSTEP 0
260	#define POSSTEP 1
261	#define NEGSTEP 2
262
263
264	exdo(range, spec)
265	int range;
266	chainp spec;
267	{
268	register expptr p, q;
269	expptr q1;
270	register Namep np;
271	chainp cp;
272	register int i;
273	int dotype, incsign;
274	Addrp dovarp, dostgp;
275	expptr par[3];
276
277	pushctl(CTLDO);
278	dorange = ctlstack->dolabel = range;
279	np = (Namep) (spec->datap);
280	ctlstack->donamep = NULL;
281	if(np->vdovar)
282	{
283	errstr("nested loops with variable %s", varstr(VL,np->varname));
284	ctlstack->donamep = NULL;
285	return;
286	}
287
288	dovarp = mkplace(np);
289	if( ! ONEOF(dovarp->vtype, MSKINT\|MSKREAL) )
290	{
291	err("bad type on do variable");
292	return;
293	}
294	ctlstack->donamep = np;
295
296	np->vdovar = YES;
297	if( enregister(np) )
298	{
299	/* stgp points to a storage version, varp to a register version */
300	dostgp = dovarp;
301	dovarp = mkplace(np);
302	}
303	else
304	dostgp = NULL;
305	dotype = dovarp->vtype;
306
307	for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
308	{
309	p = par[i++] = fixtype(cp->datap);
310	if( ! ONEOF(p->headblock.vtype, MSKINT\|MSKREAL) )
311	{
312	err("bad type on DO parameter");
313	return;
314	}
315	}
316
317	frchain(&spec);
318	switch(i)
319	{
320	case 0:
321	case 1:
322	err("too few DO parameters");
323	return;
324
325	default:
326	err("too many DO parameters");
327	return;
328
329	case 2:
330	DOINCR = (expptr) ICON(1);
331
332	case 3:
333	break;
334	}
335
336	ctlstack->endlabel = newlabel();
337	ctlstack->dobodylabel = newlabel();
338
339	if( ISCONST(DOLIMIT) )
340	ctlstack->domax = mkconv(dotype, DOLIMIT);
341	else
342	ctlstack->domax = (expptr) mktemp(dotype, PNULL);
343
344	if( ISCONST(DOINCR) )
345	{
346	ctlstack->dostep = mkconv(dotype, DOINCR);
347	if( (incsign = conssgn(ctlstack->dostep)) == 0)
348	err("zero DO increment");
349	ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
350	}
351	else
352	{
353	ctlstack->dostep = (expptr) mktemp(dotype, PNULL);
354	ctlstack->dostepsign = VARSTEP;
355	ctlstack->doposlabel = newlabel();
356	ctlstack->doneglabel = newlabel();
357	}
358
359	if( ISCONST(ctlstack->domax) && ISCONST(DOINIT) && ctlstack->dostepsign!=VARSTEP)
360	{
361	puteq(cpexpr(dovarp), cpexpr(DOINIT));
362	if( onetripflag )
363	frexpr(DOINIT);
364	else
365	{
366	q = mkexpr(OPPLUS, ICON(1),
367	mkexpr(OPMINUS, cpexpr(ctlstack->domax), cpexpr(DOINIT)) );
368	if(incsign != conssgn(q))
369	{
370	warn("DO range never executed");
371	putgoto(ctlstack->endlabel);
372	}
373	frexpr(q);
374	}
375	}
376	else if(ctlstack->dostepsign!=VARSTEP && !onetripflag)
377	{
378	if( ISCONST(ctlstack->domax) )
379	q = (expptr) cpexpr(ctlstack->domax);
380	else
381	q = mkexpr(OPASSIGN, cpexpr(ctlstack->domax), DOLIMIT);
382
383	q1 = mkexpr(OPASSIGN, cpexpr(dovarp), DOINIT);
384	q = mkexpr( (ctlstack->dostepsign==POSSTEP ? OPLE : OPGE), q1, q);
385	putif(q, ctlstack->endlabel);
386	}
387	else
388	{
389	if(! ISCONST(ctlstack->domax) )
390	puteq( cpexpr(ctlstack->domax), DOLIMIT);
391	q = DOINIT;
392	if( ! onetripflag )
393	q = mkexpr(OPMINUS, q,
394	mkexpr(OPASSIGN, cpexpr(ctlstack->dostep), DOINCR) );
395	puteq( cpexpr(dovarp), q);
396	if(onetripflag && ctlstack->dostepsign==VARSTEP)
397	puteq( cpexpr(ctlstack->dostep), DOINCR);
398	}
399
400	if(ctlstack->dostepsign == VARSTEP)
401	{
402	if(onetripflag)
403	putgoto(ctlstack->dobodylabel);
404	else
405	putif( mkexpr(OPGE, cpexpr(ctlstack->dostep), ICON(0)),
406	ctlstack->doneglabel );
407	putlabel(ctlstack->doposlabel);
408	putif( mkexpr(OPLE,
409	mkexpr(OPPLUSEQ, cpexpr(dovarp), cpexpr(ctlstack->dostep)),
410	cpexpr(ctlstack->domax) ),
411	ctlstack->endlabel);
412	}
413	putlabel(ctlstack->dobodylabel);
414	if(dostgp)
415	puteq(dostgp, cpexpr(dovarp));
416	frexpr(dovarp);
417	}
418
419
420
421	enddo(here)
422	int here;
423	{
424	register struct Ctlframe *q;
425	register expptr t;
426	Namep np;
427	Addrp ap;
428	register int i;
429
430	while(here == dorange)
431	{
432	if(np = ctlstack->donamep)
433	{
434	t = mkexpr(OPPLUSEQ, mkplace(ctlstack->donamep),
435	cpexpr(ctlstack->dostep) );
436
437	if(ctlstack->dostepsign == VARSTEP)
438	{
439	putif( mkexpr(OPLE, cpexpr(ctlstack->dostep), ICON(0)), ctlstack->doposlabel);
440	putlabel(ctlstack->doneglabel);
441	putif( mkexpr(OPLT, t, ctlstack->domax), ctlstack->dobodylabel);
442	}
443	else
444	putif( mkexpr( (ctlstack->dostepsign==POSSTEP ? OPGT : OPLT),
445	t, ctlstack->domax),
446	ctlstack->dobodylabel);
447	putlabel(ctlstack->endlabel);
448	if(ap = memversion(np))
449	puteq(ap, mkplace(np));
450	for(i = 0 ; i < 4 ; ++i)
451	ctlstack->ctlabels[i] = 0;
452	deregister(ctlstack->donamep);
453	ctlstack->donamep->vdovar = NO;
454	frexpr(ctlstack->dostep);
455	}
456
457	popctl();
458	poplab();
459	dorange = 0;
460	for(q = ctlstack ; q>=ctls ; --q)
461	if(q->ctltype == CTLDO)
462	{
463	dorange = q->dolabel;
464	break;
465	}
466	}
467	}
468	\f
469	exassign(vname, labelval)
470	Namep vname;
471	struct Labelblock *labelval;
472	{
473	Addrp p;
474	expptr mkaddcon();
475
476	p = mkplace(vname);
477	if( ! ONEOF(p->vtype, MSKINT\|MSKADDR) )
478	err("noninteger assign variable");
479	else
480	puteq(p, mkaddcon(labelval->labelno) );
481	}
482
483
484
485	exarif(expr, neglab, zerlab, poslab)
486	expptr expr;
487	struct Labelblock neglab, zerlab, *poslab;
488	{
489	register int lm, lz, lp;
490
491	lm = neglab->labelno;
492	lz = zerlab->labelno;
493	lp = poslab->labelno;
494	expr = fixtype(expr);
495
496	if( ! ONEOF(expr->headblock.vtype, MSKINT\|MSKREAL) )
497	{
498	err("invalid type of arithmetic if expression");
499	frexpr(expr);
500	}
501	else
502	{
503	if(lm == lz)
504	exar2(OPLE, expr, lm, lp);
505	else if(lm == lp)
506	exar2(OPNE, expr, lm, lz);
507	else if(lz == lp)
508	exar2(OPGE, expr, lz, lm);
509	else
510	prarif(expr, lm, lz, lp);
511	}
512	}
513
514
515
516	LOCAL exar2(op, e, l1, l2)
517	int op;
518	expptr e;
519	int l1, l2;
520	{
521	putif( mkexpr(op, e, ICON(0)), l2);
522	putgoto(l1);
523	}
524
525
526	exreturn(p)
527	register expptr p;
528	{
529	if(procclass != CLPROC)
530	warn("RETURN statement in main or block data");
531	if(p && (proctype!=TYSUBR \|\| procclass!=CLPROC) )
532	{
533	err("alternate return in nonsubroutine");
534	p = 0;
535	}
536
537	if(p)
538	{
539	putforce(TYINT, p);
540	putgoto(retlabel);
541	}
542	else
543	putgoto(proctype==TYSUBR ? ret0label : retlabel);
544	}
545
546
547
548	exasgoto(labvar)
549	struct Hashentry *labvar;
550	{
551	register Addrp p;
552
553	p = mkplace(labvar);
554	if( ! ISINT(p->vtype) )
555	err("assigned goto variable must be integer");
556	else
557	putbranch(p);
558	}