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