[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", 0);
}


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", 0);
}


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", 0);
}


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

if(++ctlstack >= lastctl)
	fatal("nesting too deep");
ctlstack->ctltype = code;
for(i = 0 ; i < 4 ; ++i)
	ctlstack->ctlabels[i] = 0;
++blklevel;
}


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


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), rp);
	}
}


mkstfunct(lp, rp)
struct primblock *lp;
expptr rp;
{
register struct primblock *p;
register struct nameblock *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 : NULL);
np->vardesc.vstfdesc = mkchain(args , rp );

for( ; args ; args = args->nextp)
	if( (p = args->datap)->tag!=TPRIM ||
		p->argsp || p->fcharp || p->lcharp)
		err("non-variable argument in statement function definition");
	else
		{
		vardcl(args->datap = p->namep);
		free(p);
		}
}


excall(name, args, nstars, labels)
struct hashentry *name;
struct listblock *args;
int nstars;
struct labelblock *labels[ ];
{
register expptr p;

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


exstop(stop, p)
int stop;
register expptr p;
{
char *q;
int n;
struct constblock *mkstrcon();

if(p)
	{
	if( ! ISCONST(p) )
		{
		execerr("pause/stop argument must be constant", 0);
		frexpr(p);
		p = mkstrcon(0, 0);
		}
	else if( ISINT(p->vtype) )
		{
		q = convic(p->const.ci);
		n = strlen(q);
		if(n > 0)
			{
			p->const.ccp = copyn(n, q);
			p->vtype = TYCHAR;
			p->vleng = ICON(n);
			}
		else
			p = mkstrcon(0, 0);
		}
	else if(p->vtype != TYCHAR)
		{
		execerr("pause/stop argument must be integer or string", 0);
		p = mkstrcon(0, 0);
		}
	}
else	p = mkstrcon(0, 0);

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 struct nameblock *np;
chainp cp;
register int i;
int dotype, incsign;
struct addrblock *dovarp, *dostgp;
expptr par[3];

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

dovarp = mklhs( mkprim(np, 0,0,0) );
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 = mklhs( mkprim(np, 0,0,0) );
	}
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->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 = ICON(1);

	case 3:
		break;
	}

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

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

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 = mktemp(dotype, NULL);
	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 = 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;
struct nameblock *np;
struct addrblock *ap;
register int i;

while(here == dorange)
	{
	if(np = ctlstack->donamep)
		{
		t = mkexpr(OPPLUSEQ, mklhs(mkprim(ctlstack->donamep, 0,0,0)),
			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, mklhs( mkprim(np,0,0,0)) );
		for(i = 0 ; i < 4 ; ++i)
			ctlstack->ctlabels[i] = 0;
		deregister(ctlstack->donamep);
		ctlstack->donamep->vdovar = NO;
		frexpr(ctlstack->dostep);
		}

	popctl();
	dorange = 0;
	for(q = ctlstack ; q>=ctls ; --q)
		if(q->ctltype == CTLDO)
			{
			dorange = q->dolabel;
			break;
			}
	}
}
\f
exassign(vname, labelval)
struct nameblock *vname;
struct labelblock *labelval;
{
struct addrblock *p;
struct constblock *mkaddcon();

p = mklhs(mkprim(vname,0,0,0));
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->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(p && (proctype!=TYSUBR || procclass!=CLPROC) )
	{
	err("alternate return in nonsubroutine");
	p = 0;
	}

if(p)
	{
	putforce(TYINT, p);
	putgoto(retlabel);
	}
else
	putgoto(procclass==TYSUBR ? ret0label : retlabel);
}


exasgoto(labvar)
struct hashentry *labvar;
{
register struct addrblock *p;

p = mklhs( mkprim(labvar,0,0,0) );
if( ! ISINT(p->vtype) )
	err("assigned goto variable must be integer");
else
	putbranch(p);
}
Commit	Line	Data
f2a856a6 TL	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", 0);
	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", 0);
	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 execerr("endif out of place", 0);
68	}
69
70
71
72	LOCAL pushctl(code)
73	int code;
74	{
75	register int i;
76
77	if(++ctlstack >= lastctl)
78	fatal("nesting too deep");
79	ctlstack->ctltype = code;
80	for(i = 0 ; i < 4 ; ++i)
81	ctlstack->ctlabels[i] = 0;
82	++blklevel;
83	}
84
85
86	LOCAL popctl()
87	{
88	if( ctlstack-- < ctls )
89	fatal("control stack empty");
90	--blklevel;
91	poplab();
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), 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 struct nameblock *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 : NULL);
178	np->vardesc.vstfdesc = mkchain(args , rp );
179
180	for( ; args ; args = args->nextp)
181	if( (p = args->datap)->tag!=TPRIM \|\|
182	p->argsp \|\| p->fcharp \|\| p->lcharp)
183	err("non-variable argument in statement function definition");
184	else
185	{
186	vardcl(args->datap = p->namep);
187	free(p);
188	}
189	}
190
191
192
193	excall(name, args, nstars, labels)
194	struct hashentry *name;
195	struct listblock *args;
196	int nstars;
197	struct labelblock *labels[ ];
198	{
199	register expptr p;
200
201	settype(name, TYSUBR, NULL);
202	p = mkfunct( mkprim(name, args, NULL, NULL) );
203	p->vtype = p->leftp->vtype = TYINT;
204	if(nstars > 0)
205	putcmgo(p, nstars, labels);
206	else putexpr(p);
207	}
208
209
210
211	exstop(stop, p)
212	int stop;
213	register expptr p;
214	{
215	char *q;
216	int n;
217	struct constblock *mkstrcon();
218
219	if(p)
220	{
221	if( ! ISCONST(p) )
222	{
223	execerr("pause/stop argument must be constant", 0);
224	frexpr(p);
225	p = mkstrcon(0, 0);
226	}
227	else if( ISINT(p->vtype) )
228	{
229	q = convic(p->const.ci);
230	n = strlen(q);
231	if(n > 0)
232	{
233	p->const.ccp = copyn(n, q);
234	p->vtype = TYCHAR;
235	p->vleng = ICON(n);
236	}
237	else
238	p = mkstrcon(0, 0);
239	}
240	else if(p->vtype != TYCHAR)
241	{
242	execerr("pause/stop argument must be integer or string", 0);
243	p = mkstrcon(0, 0);
244	}
245	}
246	else p = mkstrcon(0, 0);
247
248	putexpr( call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p) );
249	}
250	\f
251	/* DO LOOP CODE */
252
253	#define DOINIT par[0]
254	#define DOLIMIT par[1]
255	#define DOINCR par[2]
256
257	#define VARSTEP 0
258	#define POSSTEP 1
259	#define NEGSTEP 2
260
261
262	exdo(range, spec)
263	int range;
264	chainp spec;
265	{
266	register expptr p, q;
267	expptr *q1;
268	register struct nameblock *np;
269	chainp cp;
270	register int i;
271	int dotype, incsign;
272	struct addrblock dovarp, dostgp;
273	expptr par[3];
274
275	pushctl(CTLDO);
276	dorange = ctlstack->dolabel = range;
277	np = spec->datap;
278	ctlstack->donamep = NULL;
279	if(np->vdovar)
280	{
281	err1("nested loops with variable %s", varstr(VL,np->varname));
282	ctlstack->donamep = NULL;
283	return;
284	}
285
286	dovarp = mklhs( mkprim(np, 0,0,0) );
287	if( ! ONEOF(dovarp->vtype, MSKINT\|MSKREAL) )
288	{
289	err("bad type on do variable");
290	return;
291	}
292	ctlstack->donamep = np;
293
294	np->vdovar = YES;
295	if( enregister(np) )
296	{
297	/* stgp points to a storage version, varp to a register version */
298	dostgp = dovarp;
299	dovarp = mklhs( mkprim(np, 0,0,0) );
300	}
301	else
302	dostgp = NULL;
303	dotype = dovarp->vtype;
304
305	for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
306	{
307	p = par[i++] = fixtype(cp->datap);
308	if( ! ONEOF(p->vtype, MSKINT\|MSKREAL) )
309	{
310	err("bad type on DO parameter");
311	return;
312	}
313	}
314
315	frchain(&spec);
316	switch(i)
317	{
318	case 0:
319	case 1:
320	err("too few DO parameters");
321	return;
322
323	default:
324	err("too many DO parameters");
325	return;
326
327	case 2:
328	DOINCR = ICON(1);
329
330	case 3:
331	break;
332	}
333
334	ctlstack->endlabel = newlabel();
335	ctlstack->dobodylabel = newlabel();
336
337	if( ISCONST(DOLIMIT) )
338	ctlstack->domax = mkconv(dotype, DOLIMIT);
339	else
340	ctlstack->domax = mktemp(dotype, NULL);
341
342	if( ISCONST(DOINCR) )
343	{
344	ctlstack->dostep = mkconv(dotype, DOINCR);
345	if( (incsign = conssgn(ctlstack->dostep)) == 0)
346	err("zero DO increment");
347	ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
348	}
349	else
350	{
351	ctlstack->dostep = mktemp(dotype, NULL);
352	ctlstack->dostepsign = VARSTEP;
353	ctlstack->doposlabel = newlabel();
354	ctlstack->doneglabel = newlabel();
355	}
356
357	if( ISCONST(ctlstack->domax) && ISCONST(DOINIT) && ctlstack->dostepsign!=VARSTEP)
358	{
359	puteq(cpexpr(dovarp), cpexpr(DOINIT));
360	if( onetripflag )
361	frexpr(DOINIT);
362	else
363	{
364	q = mkexpr(OPPLUS, ICON(1),
365	mkexpr(OPMINUS, cpexpr(ctlstack->domax), cpexpr(DOINIT)) );
366	if(incsign != conssgn(q))
367	{
368	warn("DO range never executed");
369	putgoto(ctlstack->endlabel);
370	}
371	frexpr(q);
372	}
373	}
374	else if(ctlstack->dostepsign!=VARSTEP && !onetripflag)
375	{
376	if( ISCONST(ctlstack->domax) )
377	q = cpexpr(ctlstack->domax);
378	else
379	q = mkexpr(OPASSIGN, cpexpr(ctlstack->domax), DOLIMIT);
380
381	q1 = mkexpr(OPASSIGN, cpexpr(dovarp), DOINIT);
382	q = mkexpr( (ctlstack->dostepsign==POSSTEP ? OPLE : OPGE), q1, q);
383	putif(q, ctlstack->endlabel);
384	}
385	else
386	{
387	if(! ISCONST(ctlstack->domax) )
388	puteq( cpexpr(ctlstack->domax), DOLIMIT);
389	q = DOINIT;
390	if( ! onetripflag )
391	q = mkexpr(OPMINUS, q,
392	mkexpr(OPASSIGN, cpexpr(ctlstack->dostep), DOINCR) );
393	puteq( cpexpr(dovarp), q);
394	if(onetripflag && ctlstack->dostepsign==VARSTEP)
395	puteq( cpexpr(ctlstack->dostep), DOINCR);
396	}
397
398	if(ctlstack->dostepsign == VARSTEP)
399	{
400	if(onetripflag)
401	putgoto(ctlstack->dobodylabel);
402	else
403	putif( mkexpr(OPGE, cpexpr(ctlstack->dostep), ICON(0)),
404	ctlstack->doneglabel );
405	putlabel(ctlstack->doposlabel);
406	putif( mkexpr(OPLE,
407	mkexpr(OPPLUSEQ, cpexpr(dovarp), cpexpr(ctlstack->dostep)),
408	cpexpr(ctlstack->domax) ),
409	ctlstack->endlabel);
410	}
411	putlabel(ctlstack->dobodylabel);
412	if(dostgp)
413	puteq(dostgp, cpexpr(dovarp));
414	frexpr(dovarp);
415	}
416
417
418
419	enddo(here)
420	int here;
421	{
422	register struct ctlframe *q;
423	register expptr t;
424	struct nameblock *np;
425	struct addrblock *ap;
426	register int i;
427
428	while(here == dorange)
429	{
430	if(np = ctlstack->donamep)
431	{
432	t = mkexpr(OPPLUSEQ, mklhs(mkprim(ctlstack->donamep, 0,0,0)),
433	cpexpr(ctlstack->dostep) );
434
435	if(ctlstack->dostepsign == VARSTEP)
436	{
437	putif( mkexpr(OPLE, cpexpr(ctlstack->dostep), ICON(0)), ctlstack->doposlabel);
438	putlabel(ctlstack->doneglabel);
439	putif( mkexpr(OPLT, t, ctlstack->domax), ctlstack->dobodylabel);
440	}
441	else
442	putif( mkexpr( (ctlstack->dostepsign==POSSTEP ? OPGT : OPLT),
443	t, ctlstack->domax),
444	ctlstack->dobodylabel);
445	putlabel(ctlstack->endlabel);
446	if(ap = memversion(np))
447	puteq(ap, mklhs( mkprim(np,0,0,0)) );
448	for(i = 0 ; i < 4 ; ++i)
449	ctlstack->ctlabels[i] = 0;
450	deregister(ctlstack->donamep);
451	ctlstack->donamep->vdovar = NO;
452	frexpr(ctlstack->dostep);
453	}
454
455	popctl();
456	dorange = 0;
457	for(q = ctlstack ; q>=ctls ; --q)
458	if(q->ctltype == CTLDO)
459	{
460	dorange = q->dolabel;
461	break;
462	}
463	}
464	}
465	\f
466	exassign(vname, labelval)
467	struct nameblock *vname;
468	struct labelblock *labelval;
469	{
470	struct addrblock *p;
471	struct constblock *mkaddcon();
472
473	p = mklhs(mkprim(vname,0,0,0));
474	if( ! ONEOF(p->vtype, MSKINT\|MSKADDR) )
475	err("noninteger assign variable");
476	else
477	puteq(p, mkaddcon(labelval->labelno) );
478	}
479
480
481
482	exarif(expr, neglab, zerlab, poslab)
483	expptr expr;
484	struct labelblock neglab, zerlab, *poslab;
485	{
486	register int lm, lz, lp;
487
488	lm = neglab->labelno;
489	lz = zerlab->labelno;
490	lp = poslab->labelno;
491	expr = fixtype(expr);
492
493	if( ! ONEOF(expr->vtype, MSKINT\|MSKREAL) )
494	{
495	err("invalid type of arithmetic if expression");
496	frexpr(expr);
497	}
498	else
499	{
500	if(lm == lz)
501	exar2(OPLE, expr, lm, lp);
502	else if(lm == lp)
503	exar2(OPNE, expr, lm, lz);
504	else if(lz == lp)
505	exar2(OPGE, expr, lz, lm);
506	else
507	prarif(expr, lm, lz, lp);
508	}
509	}
510
511
512
513	LOCAL exar2(op, e, l1, l2)
514	int op;
515	expptr e;
516	int l1, l2;
517	{
518	putif( mkexpr(op, e, ICON(0)), l2);
519	putgoto(l1);
520	}
521
522
523	exreturn(p)
524	register expptr p;
525	{
526	if(p && (proctype!=TYSUBR \|\| procclass!=CLPROC) )
527	{
528	err("alternate return in nonsubroutine");
529	p = 0;
530	}
531
532	if(p)
533	{
534	putforce(TYINT, p);
535	putgoto(retlabel);
536	}
537	else
538	putgoto(procclass==TYSUBR ? ret0label : retlabel);
539	}
540
541
542
543	exasgoto(labvar)
544	struct hashentry *labvar;
545	{
546	register struct addrblock *p;
547
548	p = mklhs( mkprim(labvar,0,0,0) );
549	if( ! ISINT(p->vtype) )
550	err("assigned goto variable must be integer");
551	else
552	putbranch(p);
553	}