xref: /original-bsd/usr.bin/f77/pass1.vax/exec.c (revision f1656be1) 
1 /*
2  * Copyright (c) 1980 Regents of the University of California.
3  * All rights reserved.  The Berkeley software License Agreement
4  * specifies the terms and conditions for redistribution.
5  */
6 
7 #ifndef lint
8 static char sccsid[] = "@(#)exec.c	5.6 (Berkeley) 01/03/88";
9 #endif not lint
10 
11 /*
12  * exec.c
13  *
14  * Routines for handling the semantics of control structures.
15  * F77 compiler, pass 1.
16  *
17  * University of Utah CS Dept modification history:
18  *
19  * $Log:	exec.c,v $
20  * Revision 5.6  85/12/20  19:42:46  donn
21  * Change style of error reporting in last fix.
22  *
23  * Revision 5.5  85/12/20  18:54:10  donn
24  * Complain about calls to things which aren't subroutines.
25  *
26  * Revision 5.4  85/12/18  19:57:58  donn
27  * Assignment statements are executable statements -- advance the magic
28  * parser state to forbid DATA statements and statement functions.
29  *
30  * Revision 5.3  85/11/25  00:23:49  donn
31  * 4.3 beta
32  *
33  * Revision 5.2  85/08/10  04:07:36  donn
34  * Changed an error message to correct spelling and be more accurate.
35  * From Jerry Berkman.
36  *
37  * Revision 2.3  85/03/18  08:03:31  donn
38  * Hacks for conversions from type address to numeric type -- prevent addresses
39  * from being stored in shorts and prevent warnings about implicit conversions.
40  *
41  * Revision 2.2  84/09/03  23:18:30  donn
42  * When a DO loop had the same variable as its loop variable and its limit,
43  * the limit temporary was assigned to AFTER the original value of the variable
44  * was destroyed by assigning the initial value to the loop variable.  I
45  * swapped the operands of a comparison and changed the direction of the
46  * operator...  This only affected programs when optimizing.  (This may not
47  * be enough if something alters the order of evaluation of side effects
48  * later on... sigh.)
49  *
50  * Revision 2.1  84/07/19  12:02:53  donn
51  * Changed comment headers for UofU.
52  *
53  * Revision 1.3  84/07/12  18:35:12  donn
54  * Added change to enddo() to detect open 'if' blocks at the ends of loops.
55  *
56  * Revision 1.2  84/06/08  11:22:53  donn
57  * Fixed bug in exdo() -- if a loop parameter contained an instance of the loop
58  * variable and the optimizer was off, the loop variable got converted to
59  * register before the parameters were processed and so the loop parameters
60  * were initialized from garbage in the register instead of the memory version
61  * of the loop variable.
62  *
63  */
64 
65 #include "defs.h"
66 #include "optim.h"
67 
68 
69 /*   Logical IF codes
70 */
71 
72 
73 exif(p)
74 expptr p;
75 {
76 register int k;
77 pushctl(CTLIF);
78 ctlstack->elselabel = newlabel();
79 
80 if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
81 	{
82 	if(k != TYERROR)
83 		err("non-logical expression in IF statement");
84 	frexpr(p);
85 	}
86 else if (optimflag)
87 	optbuff (SKIFN, p, ctlstack->elselabel, 0);
88 else
89 	putif (p, ctlstack->elselabel);
90 }
91 
92 
93 
94 exelif(p)
95 expptr p;
96 {
97 int k,oldelse;
98 
99 if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
100 	{
101 	if(k != TYERROR)
102 		err("non-logical expression in IF statement");
103 	frexpr(p);
104 	}
105 else    {
106         if(ctlstack->ctltype == CTLIF)
107 		{
108 		if(ctlstack->endlabel == 0) ctlstack->endlabel = newlabel();
109         	oldelse=ctlstack->elselabel;
110 		ctlstack->elselabel = newlabel();
111 		if (optimflag)
112 			{
113 			optbuff (SKGOTO, 0, ctlstack->endlabel, 0);
114 			optbuff (SKLABEL, 0, oldelse, 0);
115 			optbuff (SKIFN, p, ctlstack->elselabel, 0);
116 			}
117 		else
118 			{
119 			putgoto (ctlstack->endlabel);
120 			putlabel (oldelse);
121 			putif (p, ctlstack->elselabel);
122 			}
123 		}
124         else	execerr("elseif out of place", CNULL);
125         }
126 }
127 
128 
129 
130 
131 
132 exelse()
133 {
134 if(ctlstack->ctltype==CTLIF)
135 	{
136 	if(ctlstack->endlabel == 0)
137 		ctlstack->endlabel = newlabel();
138 	ctlstack->ctltype = CTLELSE;
139 	if (optimflag)
140 		{
141 		optbuff (SKGOTO, 0, ctlstack->endlabel, 0);
142 		optbuff (SKLABEL, 0, ctlstack->elselabel, 0);
143 		}
144 	else
145 		{
146 		putgoto (ctlstack->endlabel);
147 		putlabel (ctlstack->elselabel);
148 		}
149 	}
150 
151 else	execerr("else out of place", CNULL);
152 }
153 
154 
155 exendif()
156 {
157 if (ctlstack->ctltype == CTLIF)
158 	{
159 	if (optimflag)
160 		{
161 		optbuff (SKLABEL, 0, ctlstack->elselabel, 0);
162 		if (ctlstack->endlabel)
163 			optbuff (SKLABEL, 0, ctlstack->endlabel, 0);
164 		}
165 	else
166 		{
167 		putlabel (ctlstack->elselabel);
168 		if (ctlstack->endlabel)
169 			putlabel (ctlstack->endlabel);
170 		}
171 	popctl ();
172 	}
173 else if (ctlstack->ctltype == CTLELSE)
174 	{
175 	if (optimflag)
176 		optbuff (SKLABEL, 0, ctlstack->endlabel, 0);
177 	else
178 		putlabel (ctlstack->endlabel);
179 	popctl ();
180 	}
181 else
182 	execerr("endif out of place", CNULL);
183 }
184 
185 
186 
187 LOCAL pushctl(code)
188 int code;
189 {
190 register int i;
191 
192 /* fprintf(diagfile,"old blklevel %d \n",blklevel); dmpframe(ctlstack); */
193 if(++ctlstack >= lastctl)
194 	many("loops or if-then-elses", 'c');
195 ctlstack->ctltype = code;
196 for(i = 0 ; i < 4 ; ++i)
197 	ctlstack->ctlabels[i] = 0;
198 ++blklevel;
199 }
200 
201 
202 LOCAL popctl()
203 {
204 if( ctlstack-- < ctls )
205 	fatal("control stack empty");
206 --blklevel;
207 }
208 
209 
210 
211 LOCAL poplab()
212 {
213 register struct Labelblock  *lp;
214 
215 for(lp = labeltab ; lp < highlabtab ; ++lp)
216 	if(lp->labdefined)
217 		{
218 		/* mark all labels in inner blocks unreachable */
219 		if(lp->blklevel > blklevel)
220 			lp->labinacc = YES;
221 		}
222 	else if(lp->blklevel > blklevel)
223 		{
224 		/* move all labels referred to in inner blocks out a level */
225 		lp->blklevel = blklevel;
226 		}
227 }
228 
229 
230 
231 /*  BRANCHING CODE
232 */
233 
234 exgoto(lab)
235 struct Labelblock *lab;
236 {
237 if (optimflag)
238 	optbuff (SKGOTO, 0, lab->labelno, 0);
239 else
240 	putgoto (lab->labelno);
241 }
242 
243 
244 
245 
246 
247 
248 
249 exequals(lp, rp)
250 register struct Primblock *lp;
251 register expptr rp;
252 {
253 register Namep np;
254 
255 if(lp->tag != TPRIM)
256 	{
257 	err("assignment to a non-variable");
258 	frexpr(lp);
259 	frexpr(rp);
260 	}
261 else if(lp->namep->vclass!=CLVAR && lp->argsp)
262 	{
263 	if(parstate >= INEXEC)
264 		err("undimensioned array or statement function out of order");
265 	else
266 		mkstfunct(lp, rp);
267 	}
268 else
269 	{
270 	np = (Namep) lp->namep;
271 	if (np->vclass == CLPROC && np->vprocclass == PTHISPROC
272 		&& proctype == TYSUBR)
273 		{
274 		err("assignment to a subroutine name");
275 		return;
276 		}
277 	if(parstate < INDATA)
278 		enddcl();
279 	parstate = INEXEC;
280 	if (optimflag)
281 		optbuff (SKEQ, mkexpr(OPASSIGN, mklhs(lp), fixtype(rp)), 0, 0);
282 	else
283 		puteq (mklhs(lp), fixtype(rp));
284 	}
285 }
286 
287 
288 
289 mkstfunct(lp, rp)
290 struct Primblock *lp;
291 expptr rp;
292 {
293 register struct Primblock *p;
294 register Namep np;
295 chainp args;
296 
297 if(parstate < INDATA)
298 	{
299 	enddcl();
300 	parstate = INDATA;
301 	}
302 
303 np = lp->namep;
304 if(np->vclass == CLUNKNOWN)
305 	np->vclass = CLPROC;
306 else
307 	{
308 	dclerr("redeclaration of statement function", np);
309 	return;
310 	}
311 np->vprocclass = PSTFUNCT;
312 np->vstg = STGSTFUNCT;
313 impldcl(np);
314 args = (lp->argsp ? lp->argsp->listp : CHNULL);
315 np->varxptr.vstfdesc = mkchain(args , rp );
316 
317 for( ; args ; args = args->nextp)
318 	if( args->datap->tag!=TPRIM ||
319 		(p = (struct Primblock *) (args->datap) )->argsp ||
320 		p->fcharp || p->lcharp )
321 		err("non-variable argument in statement function definition");
322 	else
323 		{
324 		args->datap = (tagptr) (p->namep);
325 		vardcl(p->namep);
326 		free(p);
327 		}
328 }
329 
330 
331 
332 excall(name, args, nstars, labels)
333 Namep name;
334 struct Listblock *args;
335 int nstars;
336 struct Labelblock *labels[ ];
337 {
338 register expptr p;
339 
340 if (name->vdcldone)
341 	if (name->vclass != CLPROC && name->vclass != CLENTRY)
342 		{
343 		dclerr("call to non-subroutine", name);
344 		return;
345 		}
346 	else if (name->vtype != TYSUBR)
347 		{
348 		dclerr("subroutine invocation of function", name);
349 		return;
350 		}
351 settype(name, TYSUBR, ENULL);
352 p = mkfunct( mkprim(name, args, CHNULL) );
353 p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
354 if (nstars > 0)
355 	if (optimflag)
356 		optbuff (SKCMGOTO, p, nstars, labels);
357 	else
358 		putcmgo (p, nstars, labels);
359 else
360 	if (optimflag)
361 		optbuff (SKCALL, p, 0, 0);
362 	else
363 		putexpr (p);
364 }
365 
366 
367 
368 exstop(stop, p)
369 int stop;
370 register expptr p;
371 {
372 char *q;
373 int n;
374 expptr mkstrcon();
375 
376 if(p)
377 	{
378 	if( ! ISCONST(p) )
379 		{
380 		execerr("pause/stop argument must be constant", CNULL);
381 		frexpr(p);
382 		p = mkstrcon(0, CNULL);
383 		}
384 	else if( ISINT(p->constblock.vtype) )
385 		{
386 		q = convic(p->constblock.constant.ci);
387 		n = strlen(q);
388 		if(n > 0)
389 			{
390 			p->constblock.constant.ccp = copyn(n, q);
391 			p->constblock.vtype = TYCHAR;
392 			p->constblock.vleng = (expptr) ICON(n);
393 			}
394 		else
395 			p = (expptr) mkstrcon(0, CNULL);
396 		}
397 	else if(p->constblock.vtype != TYCHAR)
398 		{
399 		execerr("pause/stop argument must be integer or string", CNULL);
400 		p = (expptr) mkstrcon(0, CNULL);
401 		}
402 	}
403 else	p = (expptr) mkstrcon(0, CNULL);
404 
405 if (optimflag)
406 	optbuff ((stop ? SKSTOP : SKPAUSE), p, 0, 0);
407 else
408 	putexpr (call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p));
409 }
410 
411 
412 /* UCB DO LOOP CODE */
413 
414 #define DOINIT	par[0]
415 #define DOLIMIT	par[1]
416 #define DOINCR	par[2]
417 
418 #define CONSTINIT  constant[0]
419 #define CONSTLIMIT constant[1]
420 #define CONSTINCR  constant[2]
421 
422 #define VARSTEP	0
423 #define POSSTEP	1
424 #define NEGSTEP	2
425 
426 
427 exdo(range, spec)
428 int range;
429 chainp spec;
430 
431 {
432   register expptr p, q;
433   expptr q1;
434   register Namep np;
435   chainp cp;
436   register int i;
437   int dotype, incsign;
438   Addrp dovarp, dostgp;
439   expptr par[3];
440   expptr constant[3];
441   Slotp doslot;
442 
443   pushctl(CTLDO);
444   dorange = ctlstack->dolabel = range;
445   np = (Namep) (spec->datap);
446   ctlstack->donamep = NULL;
447   if(np->vdovar)
448     {
449       errstr("nested loops with variable %s", varstr(VL,np->varname));
450       return;
451     }
452 
453   dovarp = mkplace(np);
454   dotype = dovarp->vtype;
455 
456   if( ! ONEOF(dotype, MSKINT|MSKREAL) )
457     {
458       err("bad type on DO variable");
459       return;
460     }
461 
462 
463   for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
464     {
465       p = fixtype((expptr) cpexpr((tagptr) q = cp->datap));
466       if(!ONEOF(p->headblock.vtype, MSKINT|MSKREAL) )
467 	{
468 	  err("bad type on DO parameter");
469 	  return;
470 	}
471 
472 
473       if (ISCONST(q))
474 	constant[i] = mkconv(dotype, q);
475       else
476 	{
477 	  frexpr(q);
478 	  constant[i] = NULL;
479 	}
480 
481       par[i++] = mkconv(dotype, p);
482     }
483 
484   frchain(&spec);
485   switch(i)
486     {
487     case 0:
488     case 1:
489       err("too few DO parameters");
490       return;
491 
492     case 2:
493       DOINCR = (expptr) ICON(1);
494       CONSTINCR = ICON(1);
495 
496     case 3:
497       break;
498 
499     default:
500       err("too many DO parameters");
501       return;
502     }
503 
504   ctlstack->donamep = np;
505 
506   np->vdovar = YES;
507   if( !optimflag && enregister(np) )
508     {
509       /* stgp points to a storage version, varp to a register version */
510       dostgp = dovarp;
511       dovarp = mkplace(np);
512     }
513   else
514     dostgp = NULL;
515 
516   for (i = 0; i < 4; i++)
517     ctlstack->ctlabels[i] = newlabel();
518 
519   if( CONSTLIMIT )
520     ctlstack->domax = DOLIMIT;
521   else
522     ctlstack->domax = (expptr) mktemp(dotype, PNULL);
523 
524   if( CONSTINCR )
525     {
526       ctlstack->dostep = DOINCR;
527       if( (incsign = conssgn(CONSTINCR)) == 0)
528 	err("zero DO increment");
529       ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
530     }
531   else
532     {
533       ctlstack->dostep = (expptr) mktemp(dotype, PNULL);
534       ctlstack->dostepsign = VARSTEP;
535     }
536 
537 if (optimflag)
538 	doslot = optbuff (SKDOHEAD,0,0,ctlstack);
539 
540 if( CONSTLIMIT && CONSTINIT && ctlstack->dostepsign!=VARSTEP)
541 	{
542 	if (optimflag)
543 		optbuff (SKEQ,mkexpr(OPASSIGN,cpexpr(dovarp),cpexpr(DOINIT)),
544 			0,0);
545 	else
546 		puteq (cpexpr(dovarp), cpexpr(DOINIT));
547 	if( ! onetripflag )
548 		{
549 		q = mkexpr(OPMINUS, cpexpr(CONSTLIMIT), cpexpr(CONSTINIT));
550 		if((incsign * conssgn(q)) == -1)
551 			{
552 			warn("DO range never executed");
553 			if (optimflag)
554 				optbuff (SKGOTO,0,ctlstack->endlabel,0);
555 			else
556 				putgoto (ctlstack->endlabel);
557 			}
558 		frexpr(q);
559 		}
560 	}
561 
562 
563 else if (ctlstack->dostepsign != VARSTEP && !onetripflag)
564 	{
565 	if (CONSTLIMIT)
566 		q = (expptr) cpexpr(ctlstack->domax);
567 	else
568 		q = mkexpr(OPASSIGN, cpexpr(ctlstack->domax), DOLIMIT);
569 	q1 = mkexpr(OPASSIGN, cpexpr(dovarp), DOINIT);
570 	q = mkexpr( (ctlstack->dostepsign == POSSTEP ? OPGE : OPLE),
571 		   q, q1);
572 	if (optimflag)
573 		optbuff (SKIFN,q, ctlstack->endlabel,0);
574 	else
575 		putif (q, ctlstack->endlabel);
576 	}
577 else
578 	{
579 	if (!CONSTLIMIT)
580 	    if (optimflag)
581 		optbuff (SKEQ,
582 			mkexpr(OPASSIGN,cpexpr(ctlstack->domax),DOLIMIT),0,0);
583 	    else
584 		puteq (cpexpr(ctlstack->domax), DOLIMIT);
585 	q = DOINIT;
586 	if (!onetripflag)
587 		q = mkexpr(OPMINUS, q,
588 			mkexpr(OPASSIGN, cpexpr(ctlstack->dostep),
589 			       DOINCR) );
590 	if (optimflag)
591 		optbuff (SKEQ,mkexpr(OPASSIGN,cpexpr(dovarp), q),0,0);
592 	else
593 		puteq (cpexpr(dovarp), q);
594 	if (onetripflag && ctlstack->dostepsign == VARSTEP)
595 	    if (optimflag)
596 		optbuff (SKEQ,
597 			mkexpr(OPASSIGN,cpexpr(ctlstack->dostep),DOINCR),0,0);
598 	    else
599 		puteq (cpexpr(ctlstack->dostep), DOINCR);
600 	}
601 
602 if (ctlstack->dostepsign == VARSTEP)
603 	{
604 	expptr incr,test;
605 	if (onetripflag)
606 		if (optimflag)
607 			optbuff (SKGOTO,0,ctlstack->dobodylabel,0);
608 		else
609 			putgoto (ctlstack->dobodylabel);
610 	else
611 	    if (optimflag)
612 		optbuff (SKIFN,mkexpr(OPGE, cpexpr(ctlstack->dostep), ICON(0)),
613 			ctlstack->doneglabel,0);
614 	    else
615 		putif (mkexpr(OPGE, cpexpr(ctlstack->dostep), ICON(0)),
616 			ctlstack->doneglabel);
617 	if (optimflag)
618 		optbuff (SKLABEL,0,ctlstack->doposlabel,0);
619 	else
620 		putlabel (ctlstack->doposlabel);
621 	incr = mkexpr(OPPLUSEQ, cpexpr(dovarp), cpexpr(ctlstack->dostep));
622 	test = mkexpr(OPLE, incr, cpexpr(ctlstack->domax));
623 	if (optimflag)
624 		optbuff (SKIFN,test, ctlstack->endlabel,0);
625 	else
626 		putif (test, ctlstack->endlabel);
627 	}
628 
629 if (optimflag)
630 	optbuff (SKLABEL,0,ctlstack->dobodylabel,0);
631 else
632 	putlabel (ctlstack->dobodylabel);
633 if (dostgp)
634 	{
635 	if (optimflag)
636 		optbuff (SKEQ,mkexpr(OPASSIGN,dostgp, dovarp),0,0);
637 	else
638 		puteq (dostgp, dovarp);
639 	}
640 else
641 	frexpr(dovarp);
642 if (optimflag)
643 	doslot->nullslot = optbuff (SKNULL,0,0,0);
644 
645 frexpr(CONSTINIT);
646 frexpr(CONSTLIMIT);
647 frexpr(CONSTINCR);
648 }
649 
650 
651 enddo(here)
652 int here;
653 
654 {
655   register struct Ctlframe *q;
656   Namep np;
657   Addrp ap, rv;
658   expptr t;
659   register int i;
660   Slotp doslot;
661 
662   while (here == dorange)
663     {
664       while (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLELSE)
665 	{
666 	  execerr("missing endif", CNULL);
667 	  exendif();
668 	}
669 
670       if (np = ctlstack->donamep)
671 	{
672 	rv = mkplace (np);
673 
674 	t = mkexpr(OPPLUSEQ, cpexpr(rv), cpexpr(ctlstack->dostep) );
675 
676 	if (optimflag)
677 		doslot = optbuff (SKENDDO,0,0,ctlstack);
678 
679 	if (ctlstack->dostepsign == VARSTEP)
680 		if (optimflag)
681 			{
682 			optbuff (SKIFN,
683 				mkexpr(OPLE, cpexpr(ctlstack->dostep), ICON(0)),
684 				ctlstack->doposlabel,0);
685 			optbuff (SKLABEL,0,ctlstack->doneglabel,0);
686 			optbuff (SKIFN,mkexpr(OPLT, t, ctlstack->domax),
687 				ctlstack->dobodylabel,0);
688 			}
689 		else
690 			{
691 			putif (mkexpr(OPLE, cpexpr(ctlstack->dostep), ICON(0)),
692 				ctlstack->doposlabel);
693 			putlabel (ctlstack->doneglabel);
694 			putif (mkexpr(OPLT, t, ctlstack->domax),
695 				ctlstack->dobodylabel);
696 			}
697 	else
698 		{
699 		int op;
700 		op = (ctlstack->dostepsign == POSSTEP ? OPGT : OPLT);
701 		if (optimflag)
702 			optbuff (SKIFN, mkexpr(op,t,ctlstack->domax),
703 				ctlstack->dobodylabel,0);
704 		else
705 			putif (mkexpr(op, t, ctlstack->domax),
706 				ctlstack->dobodylabel);
707 		}
708 	if (optimflag)
709 		optbuff (SKLABEL,0,ctlstack->endlabel,0);
710 	else
711 		putlabel (ctlstack->endlabel);
712 
713 	if (ap = memversion(np))
714 		{
715 		if (optimflag)
716 			optbuff (SKEQ,mkexpr(OPASSIGN,ap, rv),0,0);
717 		else
718 			puteq (ap, rv);
719 		}
720 	else
721 		frexpr(rv);
722 	for (i = 0; i < 4; i++)
723 		ctlstack->ctlabels[i] = 0;
724 	if (!optimflag)
725 		deregister(ctlstack->donamep);
726 	ctlstack->donamep->vdovar = NO;
727 	if (optimflag)
728 		doslot->nullslot = optbuff (SKNULL,0,0,0);
729 	}
730 
731       popctl();
732       poplab();
733 
734       dorange = 0;
735       for (q = ctlstack; q >= ctls; --q)
736 	if (q->ctltype == CTLDO)
737 	  {
738 	    dorange = q->dolabel;
739 	    break;
740 	  }
741     }
742 }
743 
744 
745 exassign(vname, labelval)
746 Namep vname;
747 struct Labelblock *labelval;
748 {
749 Addrp p;
750 expptr mkaddcon();
751 
752 p = mkplace(vname);
753 #if SZADDR > SZSHORT
754 if( p->vtype == TYSHORT )
755 	err("insufficient precision in ASSIGN variable");
756 else
757 #endif
758 if( ! ONEOF(p->vtype, MSKINT|MSKADDR) )
759 	err("noninteger assign variable");
760 else
761 	{
762 	if (optimflag)
763 		optbuff (SKASSIGN, p, labelval->labelno, 0);
764 	else
765 		puteq (p, intrconv(p->vtype, mkaddcon(labelval->labelno)));
766 	}
767 }
768 
769 
770 
771 exarif(expr, neglab, zerlab, poslab)
772 expptr expr;
773 struct Labelblock *neglab, *zerlab, *poslab;
774 {
775 register int lm, lz, lp;
776 struct Labelblock *labels[3];
777 
778 lm = neglab->labelno;
779 lz = zerlab->labelno;
780 lp = poslab->labelno;
781 expr = fixtype(expr);
782 
783 if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) )
784 	{
785 	err("invalid type of arithmetic if expression");
786 	frexpr(expr);
787 	}
788 else
789 	{
790 	if(lm == lz)
791 		exar2(OPLE, expr, lm, lp);
792 	else if(lm == lp)
793 		exar2(OPNE, expr, lm, lz);
794 	else if(lz == lp)
795 		exar2(OPGE, expr, lz, lm);
796 	else
797 		if (optimflag)
798 			{
799 			labels[0] = neglab;
800 			labels[1] = zerlab;
801 			labels[2] = poslab;
802 			optbuff (SKARIF, expr, 0, labels);
803 			}
804 		else
805 			prarif(expr, lm, lz, lp);
806 	}
807 }
808 
809 
810 
811 LOCAL exar2 (op, e, l1, l2)
812 int	op;
813 expptr	e;
814 int	l1,l2;
815 {
816 if (optimflag)
817 	{
818 	optbuff (SKIFN, mkexpr(op, e, ICON(0)), l2, 0);
819 	optbuff (SKGOTO, 0, l1, 0);
820 	}
821 else
822 	{
823 	putif (mkexpr(op, e, ICON(0)), l2);
824 	putgoto (l1);
825 	}
826 }
827 
828 
829 exreturn(p)
830 register expptr p;
831 {
832 if(procclass != CLPROC)
833 	warn("RETURN statement in main or block data");
834 if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
835 	{
836 	err("alternate return in nonsubroutine");
837 	p = 0;
838 	}
839 
840 if(p)
841 	if (optimflag)
842 		optbuff (SKRETURN, p, retlabel, 0);
843 	else
844 		{
845 		putforce (TYINT, p);
846 		putgoto (retlabel);
847 		}
848 else
849 	if (optimflag)
850 		optbuff (SKRETURN, p,
851 			 (proctype==TYSUBR ? ret0label : retlabel), 0);
852 	else
853 		putgoto (proctype==TYSUBR ? ret0label : retlabel);
854 }
855 
856 
857 
858 exasgoto(labvar)
859 struct Hashentry *labvar;
860 {
861 register Addrp p;
862 
863 p = mkplace(labvar);
864 if( ! ISINT(p->vtype) )
865 	err("assigned goto variable must be integer");
866 else
867 	if (optimflag)
868 		optbuff (SKASGOTO, p, 0, 0);
869 	else
870 		putbranch (p);
871 }
872