[unix-history] / usr / src / old / efl / exec.c

#include "defs"

exlab(n)
register int n;
{
if(n==0 && thisexec->labelno && !(thisexec->labused))
	{
	thisexec->labused = 1;
	n = thisexec->labelno;
	}

if(!prevbg || n!=0)  /* avoid empty statement */
	{
	if(comments && !afterif) putcomment();
	putic(ICBEGIN, n);
	putic(ICINDENT, ctllevel);
	if(n != 0)
		if(stnos[n] != 0)
			fatal("statement number changed");
		else	stnos[n] = ( nxtstno += tailor.deltastno) ;
	TEST fprintf(diagfile, "LABEL %d\n", n);
	thisexec->nftnst++;
	afterif = 0;
	}
}


exgoto(n)
int n;
{
exlab(0);
exgo1(n);
}

exgoind(n)
int n;
{
exlab(0);
putic(ICKEYWORD,FGOTO);
putic(ICINDPTR,n);
TEST fprintf(diagfile, "goto indirect %o\n", n);
}


exgo1(n)
int n;
{
putic(ICKEYWORD,FGOTO);
putic(ICLABEL,n);
TEST fprintf(diagfile, "goto %d\n", n);
}


excompgoto(labs,index)
ptr labs;
register ptr index;
{
register int first;
register ptr p;

index = simple(LVAL,index);
if(tailor.ftn77)
	exlab(0);
else
	{
	int ncases = 0;
	for(p = labs ; p ; p = p->nextp)
		++ncases;
	exif1( mknode(TLOGOP, OPAND,
		mknode(TRELOP,OPGT, cpexpr(index), mkint(0)),
		mknode(TRELOP,OPLE, cpexpr(index), mkint(ncases)) ));
	}

putic(ICKEYWORD, FGOTO);
putic(ICOP,OPLPAR);

first = 1;
for(p = labs ; p ; p = p->nextp)
	{
	if(first)   first = 0;
	else   putic(ICOP,OPCOMMA);
	putic(ICLABEL,p->datap);
	}
putic(ICOP,OPRPAR);
frchain(&labs);

putic(ICOP,OPCOMMA);
prexpr(index);
frexpr(index);
TEST fprintf(diagfile, "computed goto\n");
}


excall(p)
register ptr p;
{
register ptr q1, q2, q3;
ptr mkholl(), exioop();

if(p->tag==TNAME || p->tag==TFTNBLOCK)
	p = mkcall(p, PNULL);

if(p->tag == TERROR)
	{
	frexpr(p);
	return;
	}
if(p->tag != TCALL)
	badtag("excall", p->tag);

q1 = p->leftp;
q2 = (q1->tag==TFTNBLOCK ? q1 : q1->sthead->varp);
if(q2->vtype!=TYUNDEFINED && q2->vtype!=TYSUBR)
	{
	dclerr("attempt to use a variable as a subroutine", p->sthead->namep);
	frexpr(p);
	return;
	}
q1->vtype = q2->vtype = TYSUBR;
if(q1->vdcldone==0)
	dclit(q1);

if(q1->tag == TNAME)
	{
	if( equals(q2->sthead->namep, "stop") )
		{
		exlab(0);
		putic(ICKEYWORD, FSTOP);
		TEST fprintf(diagfile,"stop ");
		if( (q1 = p->rightp) && (q1 = q1->leftp) )
			prexpr( simple(RVAL, q1->datap) );
		goto done;
		}
	if( ioop(q2->sthead->namep) )
		{
		exioop(p,NO);
		goto done;
		}
	}

p = simple(RVAL,p);
exlab(0);
putic(ICKEYWORD,FCALL);
TEST fprintf(diagfile, "call ");
/* replace character constant arguments with holleriths */
if( (q1=p->rightp) && tailor.hollincall)
	for(q1 = q1->leftp ; q1 ; q1 = q1->nextp)
		if( (q2 = q1->datap)->tag==TCONST
		    && q2->vtype==TYCHAR)
			{
			q2->vtype = TYHOLLERITH;
			frexpr(q2->vtypep);
			q2->vtypep = 0;
			q2->leftp = mkholl(q3 = q2->leftp);
			cfree(q3);
			}
prexpr( p );

done:	frexpr(p);
}


ptr mkholl(p)
register char *p;
{
register char *q, *t, *s;
int n;

n = strlen(p);
q = convic(n);
s = t = calloc(n + 2 + strlen(q) , 1);
while(*q)
	*t++ = *q++;
*t++ = 'h';
while(*t++ = *p++ )
	;
return(s);
}


ptr ifthen()
{
ptr p;
ptr addexec();

p = addexec();
thisexec->brnchend = 0;
if(thisexec->nftnst == 0)
	{
	exlab(0);
	putic(ICKEYWORD,FCONTINUE);
	thisexec->nftnst = 1;
	}
if(thisexec->nftnst>1 || thisexec->labeled || thisexec->uniffable )
	{
	if(thisctl->breaklab == 0)
		thisctl->breaklab = nextlab();
	indifs[thisctl->indifn] = thisctl->breaklab;
	}
else	thisctl->breaklab = 0;
return(p);
}


exasgn(l,o,r)
ptr l;
int o;
ptr r;
{
exlab(0);
if(l->vdcldone == 0)
	dclit(l);
frexpr( simple(LVAL , mknode(TASGNOP,o,l,r)) );
}

exretn(p)
ptr p;
{
if(p)
	{
	if(procname && procname->vtype && procname->vtype!=TYCHAR &&
	  (procname->vtype!=TYLCOMPLEX || tailor.lngcxtype!=NULL) )
		{
		if(p->tag!=TNAME || p->sthead!=procname->sthead)
			exasgn( cpexpr(procname) , OPASGN, p);
		}
	else execerr("can only return values in a function", PNULL);
	}
else if(procname && procname->vtype)
	 warn("function return without data value");
exlab(0);
putic(ICKEYWORD, FRETURN);

TEST {fprintf(diagfile, "exec: return( " );  prexpr(p);  fprintf(diagfile, ")\n" );  }
}


exnull()
{
if(thisexec->labelno && !(thisexec->labused) )
	{
	exlab(0);
	putic(ICKEYWORD,FCONTINUE);
	}
}


exbrk(opnext,levskip,btype)
int opnext;
ptr levskip;
int btype;
{

if(opnext && (btype==STSWITCH || btype==STPROC))
	execerr("illegal next", PNULL);
else if(!opnext && btype==STPROC)
	exretn(PNULL);
else  brknxtlab(opnext,levskip,btype);
TEST fprintf(diagfile, "exec: %s\n", (opnext ? "next" : "exit"));

}


exif(e)
register ptr e;
{
int tag;

if( (tag = e->tag)==TERROR || e->vtype!=TYLOG)
	{
	frexpr(e);
	e = mkconst(TYLOG, ".true.");
	if(tag != TERROR)
		execerr("non-logical conditional expression in if", PNULL);
	}
TEST fprintf(diagfile, "exif called\n");
e = simple(RVAL,e);
exlab(0);
putic(ICKEYWORD,FIF2);
indifs[thisctl->indifn = nextindif()] = 0;
putic(ICINDPTR, thisctl->indifn);
putic(ICOP,OPLPAR);
prexpr(e);
putic(ICOP,OPRPAR);
putic(ICMARK,0);
putic(ICOP,OPLPAR);
prexpr(e = simple(RVAL, mknode(TNOTOP,OPNOT,e,PNULL)));
putic(ICOP,OPRPAR);
putic(ICMARK,0);
afterif = 1;
frexpr(e);
}


exifgo(e,l)
ptr e;
int l;
{
exlab(0);
exif1(e);
exgo1(l);
}


exif1(e)
register ptr e;
{
e = simple(RVAL,e);
exlab(0);
putic(ICKEYWORD,FIF1);
putic(ICOP,OPLPAR);
TEST fprintf(diagfile, "if1 ");
prexpr( e );
frexpr(e);
putic(ICOP,OPRPAR);
putic(ICBLANK, 1);
}


brkcase()
{
ptr bgnexec();

if(ncases==0 /* && thisexec->prevexec->brnchend==0 */ )
	{
	exbrk(0, PNULL, 0);
	addexec();
	bgnexec();
	}
ncases = 1;
}


brknxtlab(opnext, levp, btype)
int opnext;
ptr levp;
int btype;
{
register ptr p;
int levskip;

levskip = ( levp ? convci(levp->leftp) : 1);
if(levskip <= 0)
	{
	execerr("illegal break count %d", levskip);
	return;
	}

for(p = thisctl ; p!=0 ; p = p->prevctl)
	if( (btype==0 || p->subtype==btype) &&
	    p->subtype!=STIF && p->subtype!=STPROC &&
	    (!opnext || p->subtype!=STSWITCH) )
		if(--levskip == 0) break;

if(p == 0)
	{
	execerr("invalid break/next", PNULL);
	return;
	}

if(p->subtype==STREPEAT && opnext)
	exgoind(p->indifn);
else if(opnext)
	exgoto(p->nextlab);
else	{
	if(p->breaklab == 0)
		p->breaklab = nextlab();
	exgoto(p->breaklab);
	}
}


ptr doloop(p1,p2,p3)
ptr p1;
ptr p2;
ptr p3;
{
register ptr p, q;
register int i;
int val[3];

p = ALLOC(doblock);
p->tag = TDOBLOCK;

if(p1->tag!=TASGNOP || p1->subtype!=OPASGN || p1->leftp->tag!=TNAME)
	{
	p->dovar = gent(TYINT, PNULL);
	p->dopar[0] = p1;
	}
else	{
	p->dovar = p1->leftp;
	p->dopar[0] = p1->rightp;
	frexpblock(p1);
	}
if(p2 == 0)
	{
	p->dopar[1] = p->dopar[0];
	p->dopar[0] = mkint(1);
	}
else	p->dopar[1] = p2;
p->dopar[2] = p3;

for(i = 0; i<3 ; ++i)
	{
	if(q = p->dopar[i])
		{
		if( (q->tag==TNAME || q->tag==TTEMP) &&
		   (q->vsubs || q->voffset) )
			p->dopar[i] = simple(RVAL,mknode(TASGNOP,0,
				gent(TYINT,PNULL), q));
		else
			p->dopar[i] = simple(LVAL, coerce(TYINT, q) );

		if(isicon(p->dopar[i], &val[i]))
			{
			if(val[i] <= 0)
				execerr("do parameter out of range", PNULL);
			}
		else	val[i] = -1;
		}
	}

if(val[0]>0 && val[1]>0 && val[0]>val[1])
	execerr("do parameters out of order", PNULL);
return(p);
}
Commit	Line	Data
64836102 C	1	#include "defs"
	2
	3	exlab(n)
	4	register int n;
	5	{
	6	if(n==0 && thisexec->labelno && !(thisexec->labused))
	7	{
	8	thisexec->labused = 1;
	9	n = thisexec->labelno;
	10	}
	11
	12	if(!prevbg \|\| n!=0) /* avoid empty statement */
	13	{
	14	if(comments && !afterif) putcomment();
	15	putic(ICBEGIN, n);
	16	putic(ICINDENT, ctllevel);
	17	if(n != 0)
	18	if(stnos[n] != 0)
	19	fatal("statement number changed");
	20	else stnos[n] = ( nxtstno += tailor.deltastno) ;
	21	TEST fprintf(diagfile, "LABEL %d\n", n);
	22	thisexec->nftnst++;
	23	afterif = 0;
	24	}
	25	}
	26
	27
	28	exgoto(n)
	29	int n;
	30	{
	31	exlab(0);
	32	exgo1(n);
	33	}
	34
	35	exgoind(n)
	36	int n;
	37	{
	38	exlab(0);
	39	putic(ICKEYWORD,FGOTO);
	40	putic(ICINDPTR,n);
	41	TEST fprintf(diagfile, "goto indirect %o\n", n);
	42	}
	43
	44
	45
	46	exgo1(n)
	47	int n;
	48	{
	49	putic(ICKEYWORD,FGOTO);
	50	putic(ICLABEL,n);
	51	TEST fprintf(diagfile, "goto %d\n", n);
	52	}
	53
	54
	55	excompgoto(labs,index)
	56	ptr labs;
	57	register ptr index;
	58	{
	59	register int first;
	60	register ptr p;
	61
	62	index = simple(LVAL,index);
	63	if(tailor.ftn77)
	64	exlab(0);
65	else
66	{
67	int ncases = 0;
68	for(p = labs ; p ; p = p->nextp)
69	++ncases;
70	exif1( mknode(TLOGOP, OPAND,
71	mknode(TRELOP,OPGT, cpexpr(index), mkint(0)),
72	mknode(TRELOP,OPLE, cpexpr(index), mkint(ncases)) ));
73	}
74
75	putic(ICKEYWORD, FGOTO);
76	putic(ICOP,OPLPAR);
77
78	first = 1;
79	for(p = labs ; p ; p = p->nextp)
80	{
81	if(first) first = 0;
82	else putic(ICOP,OPCOMMA);
83	putic(ICLABEL,p->datap);
84	}
85	putic(ICOP,OPRPAR);
86	frchain(&labs);
87
88	putic(ICOP,OPCOMMA);
89	prexpr(index);
90	frexpr(index);
91	TEST fprintf(diagfile, "computed goto\n");
92	}
93
94
95
96
97	excall(p)
98	register ptr p;
99	{
100	register ptr q1, q2, q3;
101	ptr mkholl(), exioop();
102
103	if(p->tag==TNAME \|\| p->tag==TFTNBLOCK)
104	p = mkcall(p, PNULL);
105
106	if(p->tag == TERROR)
107	{
108	frexpr(p);
109	return;
110	}
111	if(p->tag != TCALL)
112	badtag("excall", p->tag);
113
114	q1 = p->leftp;
115	q2 = (q1->tag==TFTNBLOCK ? q1 : q1->sthead->varp);
116	if(q2->vtype!=TYUNDEFINED && q2->vtype!=TYSUBR)
117	{
118	dclerr("attempt to use a variable as a subroutine", p->sthead->namep);
119	frexpr(p);
120	return;
121	}
122	q1->vtype = q2->vtype = TYSUBR;
123	if(q1->vdcldone==0)
124	dclit(q1);
125
126	if(q1->tag == TNAME)
127	{
128	if( equals(q2->sthead->namep, "stop") )
129	{
130	exlab(0);
131	putic(ICKEYWORD, FSTOP);
132	TEST fprintf(diagfile,"stop ");
133	if( (q1 = p->rightp) && (q1 = q1->leftp) )
134	prexpr( simple(RVAL, q1->datap) );
135	goto done;
136	}
137	if( ioop(q2->sthead->namep) )
138	{
139	exioop(p,NO);
140	goto done;
141	}
142	}
143
144	p = simple(RVAL,p);
145	exlab(0);
146	putic(ICKEYWORD,FCALL);
147	TEST fprintf(diagfile, "call ");
148	/* replace character constant arguments with holleriths */
149	if( (q1=p->rightp) && tailor.hollincall)
150	for(q1 = q1->leftp ; q1 ; q1 = q1->nextp)
151	if( (q2 = q1->datap)->tag==TCONST
152	&& q2->vtype==TYCHAR)
153	{
154	q2->vtype = TYHOLLERITH;
155	frexpr(q2->vtypep);
156	q2->vtypep = 0;
157	q2->leftp = mkholl(q3 = q2->leftp);
158	cfree(q3);
159	}
160	prexpr( p );
161
162	done: frexpr(p);
163	}
164
165
166
167
168	ptr mkholl(p)
169	register char *p;
170	{
171	register char q, t, *s;
172	int n;
173
174	n = strlen(p);
175	q = convic(n);
176	s = t = calloc(n + 2 + strlen(q) , 1);
177	while(*q)
178	t++ = q++;
179	*t++ = 'h';
180	while(t++ = p++ )
181	;
182	return(s);
183	}
184
185
186	ptr ifthen()
187	{
188	ptr p;
189	ptr addexec();
190
191	p = addexec();
192	thisexec->brnchend = 0;
193	if(thisexec->nftnst == 0)
194	{
195	exlab(0);
196	putic(ICKEYWORD,FCONTINUE);
197	thisexec->nftnst = 1;
198	}
199	if(thisexec->nftnst>1 \|\| thisexec->labeled \|\| thisexec->uniffable )
200	{
201	if(thisctl->breaklab == 0)
202	thisctl->breaklab = nextlab();
203	indifs[thisctl->indifn] = thisctl->breaklab;
204	}
205	else thisctl->breaklab = 0;
206	return(p);
207	}
208
209
210
211	exasgn(l,o,r)
212	ptr l;
213	int o;
214	ptr r;
215	{
216	exlab(0);
217	if(l->vdcldone == 0)
218	dclit(l);
219	frexpr( simple(LVAL , mknode(TASGNOP,o,l,r)) );
220	}
221
222	exretn(p)
223	ptr p;
224	{
225	if(p)
226	{
227	if(procname && procname->vtype && procname->vtype!=TYCHAR &&
228	(procname->vtype!=TYLCOMPLEX \|\| tailor.lngcxtype!=NULL) )
229	{
230	if(p->tag!=TNAME \|\| p->sthead!=procname->sthead)
231	exasgn( cpexpr(procname) , OPASGN, p);
232	}
233	else execerr("can only return values in a function", PNULL);
234	}
235	else if(procname && procname->vtype)
236	warn("function return without data value");
237	exlab(0);
238	putic(ICKEYWORD, FRETURN);
239
240	TEST {fprintf(diagfile, "exec: return( " ); prexpr(p); fprintf(diagfile, ")\n" ); }
241	}
242
243
244	exnull()
245	{
246	if(thisexec->labelno && !(thisexec->labused) )
247	{
248	exlab(0);
249	putic(ICKEYWORD,FCONTINUE);
250	}
251	}
252
253
254
255
256	exbrk(opnext,levskip,btype)
257	int opnext;
258	ptr levskip;
259	int btype;
260	{
261
262	if(opnext && (btype==STSWITCH \|\| btype==STPROC))
263	execerr("illegal next", PNULL);
264	else if(!opnext && btype==STPROC)
265	exretn(PNULL);
266	else brknxtlab(opnext,levskip,btype);
267	TEST fprintf(diagfile, "exec: %s\n", (opnext ? "next" : "exit"));
268
269	}
270
271
272
273	exif(e)
274	register ptr e;
275	{
276	int tag;
277
278	if( (tag = e->tag)==TERROR \|\| e->vtype!=TYLOG)
279	{
280	frexpr(e);
281	e = mkconst(TYLOG, ".true.");
282	if(tag != TERROR)
283	execerr("non-logical conditional expression in if", PNULL);
284	}
285	TEST fprintf(diagfile, "exif called\n");
286	e = simple(RVAL,e);
287	exlab(0);
288	putic(ICKEYWORD,FIF2);
289	indifs[thisctl->indifn = nextindif()] = 0;
290	putic(ICINDPTR, thisctl->indifn);
291	putic(ICOP,OPLPAR);
292	prexpr(e);
293	putic(ICOP,OPRPAR);
294	putic(ICMARK,0);
295	putic(ICOP,OPLPAR);
296	prexpr(e = simple(RVAL, mknode(TNOTOP,OPNOT,e,PNULL)));
297	putic(ICOP,OPRPAR);
298	putic(ICMARK,0);
299	afterif = 1;
300	frexpr(e);
301	}
302
303
304	exifgo(e,l)
305	ptr e;
306	int l;
307	{
308	exlab(0);
309	exif1(e);
310	exgo1(l);
311	}
312
313
314	exif1(e)
315	register ptr e;
316	{
317	e = simple(RVAL,e);
318	exlab(0);
319	putic(ICKEYWORD,FIF1);
320	putic(ICOP,OPLPAR);
321	TEST fprintf(diagfile, "if1 ");
322	prexpr( e );
323	frexpr(e);
324	putic(ICOP,OPRPAR);
325	putic(ICBLANK, 1);
326	}
327
328
329
330
331
332
333
334	brkcase()
335	{
336	ptr bgnexec();
337
338	if(ncases==0 /* && thisexec->prevexec->brnchend==0 */ )
339	{
340	exbrk(0, PNULL, 0);
341	addexec();
342	bgnexec();
343	}
344	ncases = 1;
345	}
346
347
348	brknxtlab(opnext, levp, btype)
349	int opnext;
350	ptr levp;
351	int btype;
352	{
353	register ptr p;
354	int levskip;
355
356	levskip = ( levp ? convci(levp->leftp) : 1);
357	if(levskip <= 0)
358	{
359	execerr("illegal break count %d", levskip);
360	return;
361	}
362
363	for(p = thisctl ; p!=0 ; p = p->prevctl)
364	if( (btype==0 \|\| p->subtype==btype) &&
365	p->subtype!=STIF && p->subtype!=STPROC &&
366	(!opnext \|\| p->subtype!=STSWITCH) )
367	if(--levskip == 0) break;
368
369	if(p == 0)
370	{
371	execerr("invalid break/next", PNULL);
372	return;
373	}
374
375	if(p->subtype==STREPEAT && opnext)
376	exgoind(p->indifn);
377	else if(opnext)
378	exgoto(p->nextlab);
379	else {
380	if(p->breaklab == 0)
381	p->breaklab = nextlab();
382	exgoto(p->breaklab);
383	}
384	}
385
386
387
388	ptr doloop(p1,p2,p3)
389	ptr p1;
390	ptr p2;
391	ptr p3;
392	{
393	register ptr p, q;
394	register int i;
395	int val[3];
396
397	p = ALLOC(doblock);
398	p->tag = TDOBLOCK;
399
400	if(p1->tag!=TASGNOP \|\| p1->subtype!=OPASGN \|\| p1->leftp->tag!=TNAME)
401	{
402	p->dovar = gent(TYINT, PNULL);
403	p->dopar[0] = p1;
404	}
405	else {
406	p->dovar = p1->leftp;
407	p->dopar[0] = p1->rightp;
408	frexpblock(p1);
409	}
410	if(p2 == 0)
411	{
412	p->dopar[1] = p->dopar[0];
413	p->dopar[0] = mkint(1);
414	}
415	else p->dopar[1] = p2;
416	p->dopar[2] = p3;
417
418	for(i = 0; i<3 ; ++i)
419	{
420	if(q = p->dopar[i])
421	{
422	if( (q->tag==TNAME \|\| q->tag==TTEMP) &&
423	(q->vsubs \|\| q->voffset) )
424	p->dopar[i] = simple(RVAL,mknode(TASGNOP,0,
425	gent(TYINT,PNULL), q));
426	else
427	p->dopar[i] = simple(LVAL, coerce(TYINT, q) );
428
429	if(isicon(p->dopar[i], &val[i]))
430	{
431	if(val[i] <= 0)
432	execerr("do parameter out of range", PNULL);
433	}
434	else val[i] = -1;
435	}
436	}
437
438	if(val[0]>0 && val[1]>0 && val[0]>val[1])
439	execerr("do parameters out of order", PNULL);
440	return(p);
441	}