![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to exec.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / usr.bin / f77 / src / f77pass1|
Return to exec.c CVS log | Up to [CSRG BSD Unix] / 42BSD / usr.bin / f77 / src / f77pass1 |
1.1 root 1: /* %W% (Berkeley) %G% */
2: #include "defs.h"
3: #include "optim.h"
4:
5:
6: /* Logical IF codes
7: */
8:
9:
10: exif(p)
11: expptr p;
12: {
13: register int k;
14: pushctl(CTLIF);
15: ctlstack->elselabel = newlabel();
16:
17: if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
18: {
19: if(k != TYERROR)
20: err("non-logical expression in IF statement");
21: frexpr(p);
22: }
23: else if (optimflag)
24: optbuff (SKIFN, p, ctlstack->elselabel, 0);
25: else
26: putif (p, ctlstack->elselabel);
27: }
28:
29:
30:
31: exelif(p)
32: expptr p;
33: {
34: int k,oldelse;
35:
36: if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
37: {
38: if(k != TYERROR)
39: err("non-logical expression in IF statement");
40: frexpr(p);
41: }
42: else {
43: if(ctlstack->ctltype == CTLIF)
44: {
45: if(ctlstack->endlabel == 0) ctlstack->endlabel = newlabel();
46: oldelse=ctlstack->elselabel;
47: ctlstack->elselabel = newlabel();
48: if (optimflag)
49: {
50: optbuff (SKGOTO, 0, ctlstack->endlabel, 0);
51: optbuff (SKLABEL, 0, oldelse, 0);
52: optbuff (SKIFN, p, ctlstack->elselabel, 0);
53: }
54: else
55: {
56: putgoto (ctlstack->endlabel);
57: putlabel (oldelse);
58: putif (p, ctlstack->elselabel);
59: }
60: }
61: else execerr("elseif out of place", CNULL);
62: }
63: }
64:
65:
66:
67:
68:
69: exelse()
70: {
71: if(ctlstack->ctltype==CTLIF)
72: {
73: if(ctlstack->endlabel == 0)
74: ctlstack->endlabel = newlabel();
75: ctlstack->ctltype = CTLELSE;
76: if (optimflag)
77: {
78: optbuff (SKGOTO, 0, ctlstack->endlabel, 0);
79: optbuff (SKLABEL, 0, ctlstack->elselabel, 0);
80: }
81: else
82: {
83: putgoto (ctlstack->endlabel);
84: putlabel (ctlstack->elselabel);
85: }
86: }
87:
88: else execerr("else out of place", CNULL);
89: }
90:
91:
92: exendif()
93: {
94: if (ctlstack->ctltype == CTLIF)
95: {
96: if (optimflag)
97: {
98: optbuff (SKLABEL, 0, ctlstack->elselabel, 0);
99: if (ctlstack->endlabel)
100: optbuff (SKLABEL, 0, ctlstack->endlabel, 0);
101: }
102: else
103: {
104: putlabel (ctlstack->elselabel);
105: if (ctlstack->endlabel)
106: putlabel (ctlstack->endlabel);
107: }
108: popctl ();
109: }
110: else if (ctlstack->ctltype == CTLELSE)
111: {
112: if (optimflag)
113: optbuff (SKLABEL, 0, ctlstack->endlabel, 0);
114: else
115: putlabel (ctlstack->endlabel);
116: popctl ();
117: }
118: else
119: execerr("endif out of place", CNULL);
120: }
121:
122:
123:
124: LOCAL pushctl(code)
125: int code;
126: {
127: register int i;
128:
129: /* fprintf(diagfile,"old blklevel %d \n",blklevel); dmpframe(ctlstack); */
130: if(++ctlstack >= lastctl)
131: many("loops or if-then-elses", 'c');
132: ctlstack->ctltype = code;
133: for(i = 0 ; i < 4 ; ++i)
134: ctlstack->ctlabels[i] = 0;
135: ++blklevel;
136: }
137:
138:
139: LOCAL popctl()
140: {
141: if( ctlstack-- < ctls )
142: fatal("control stack empty");
143: --blklevel;
144: }
145:
146:
147:
148: LOCAL poplab()
149: {
150: register struct Labelblock *lp;
151:
152: for(lp = labeltab ; lp < highlabtab ; ++lp)
153: if(lp->labdefined)
154: {
155: /* mark all labels in inner blocks unreachable */
156: if(lp->blklevel > blklevel)
157: lp->labinacc = YES;
158: }
159: else if(lp->blklevel > blklevel)
160: {
161: /* move all labels referred to in inner blocks out a level */
162: lp->blklevel = blklevel;
163: }
164: }
165:
166:
167:
168: /* BRANCHING CODE
169: */
170:
171: exgoto(lab)
172: struct Labelblock *lab;
173: {
174: if (optimflag)
175: optbuff (SKGOTO, 0, lab->labelno, 0);
176: else
177: putgoto (lab->labelno);
178: }
179:
180:
181:
182:
183:
184:
185:
186: exequals(lp, rp)
187: register struct Primblock *lp;
188: register expptr rp;
189: {
190: register Namep np;
191:
192: if(lp->tag != TPRIM)
193: {
194: err("assignment to a non-variable");
195: frexpr(lp);
196: frexpr(rp);
197: }
198: else if(lp->namep->vclass!=CLVAR && lp->argsp)
199: {
200: if(parstate >= INEXEC)
201: err("assignment to an undimemsioned array");
202: else
203: mkstfunct(lp, rp);
204: }
205: else
206: {
207: np = (Namep) lp->namep;
208: if (np->vclass == CLPROC && np->vprocclass == PTHISPROC
209: && proctype == TYSUBR)
210: {
211: err("assignment to a subroutine name");
212: return;
213: }
214: if(parstate < INDATA)
215: enddcl();
216: if (optimflag)
217: optbuff (SKEQ, mkexpr(OPASSIGN, mklhs(lp), fixtype(rp)), 0, 0);
218: else
219: puteq (mklhs(lp), fixtype(rp));
220: }
221: }
222:
223:
224:
225: mkstfunct(lp, rp)
226: struct Primblock *lp;
227: expptr rp;
228: {
229: register struct Primblock *p;
230: register Namep np;
231: chainp args;
232:
233: if(parstate < INDATA)
234: {
235: enddcl();
236: parstate = INDATA;
237: }
238:
239: np = lp->namep;
240: if(np->vclass == CLUNKNOWN)
241: np->vclass = CLPROC;
242: else
243: {
244: dclerr("redeclaration of statement function", np);
245: return;
246: }
247: np->vprocclass = PSTFUNCT;
248: np->vstg = STGSTFUNCT;
249: impldcl(np);
250: args = (lp->argsp ? lp->argsp->listp : CHNULL);
251: np->varxptr.vstfdesc = mkchain(args , rp );
252:
253: for( ; args ; args = args->nextp)
254: if( args->datap->tag!=TPRIM ||
255: (p = (struct Primblock *) (args->datap) )->argsp ||
256: p->fcharp || p->lcharp )
257: err("non-variable argument in statement function definition");
258: else
259: {
260: args->datap = (tagptr) (p->namep);
261: vardcl(p->namep);
262: free(p);
263: }
264: }
265:
266:
267:
268: excall(name, args, nstars, labels)
269: Namep name;
270: struct Listblock *args;
271: int nstars;
272: struct Labelblock *labels[ ];
273: {
274: register expptr p;
275:
276: settype(name, TYSUBR, ENULL);
277: p = mkfunct( mkprim(name, args, CHNULL) );
278: p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
279: if (nstars > 0)
280: if (optimflag)
281: optbuff (SKCMGOTO, p, nstars, labels);
282: else
283: putcmgo (p, nstars, labels);
284: else
285: if (optimflag)
286: optbuff (SKCALL, p, 0, 0);
287: else
288: putexpr (p);
289: }
290:
291:
292:
293: exstop(stop, p)
294: int stop;
295: register expptr p;
296: {
297: char *q;
298: int n;
299: expptr mkstrcon();
300:
301: if(p)
302: {
303: if( ! ISCONST(p) )
304: {
305: execerr("pause/stop argument must be constant", CNULL);
306: frexpr(p);
307: p = mkstrcon(0, CNULL);
308: }
309: else if( ISINT(p->constblock.vtype) )
310: {
311: q = convic(p->constblock.const.ci);
312: n = strlen(q);
313: if(n > 0)
314: {
315: p->constblock.const.ccp = copyn(n, q);
316: p->constblock.vtype = TYCHAR;
317: p->constblock.vleng = (expptr) ICON(n);
318: }
319: else
320: p = (expptr) mkstrcon(0, CNULL);
321: }
322: else if(p->constblock.vtype != TYCHAR)
323: {
324: execerr("pause/stop argument must be integer or string", CNULL);
325: p = (expptr) mkstrcon(0, CNULL);
326: }
327: }
328: else p = (expptr) mkstrcon(0, CNULL);
329:
330: if (optimflag)
331: optbuff ((stop ? SKSTOP : SKPAUSE), p, 0, 0);
332: else
333: putexpr (call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p));
334: }
335:
336:
337: /* UCB DO LOOP CODE */
338:
339: #define DOINIT par[0]
340: #define DOLIMIT par[1]
341: #define DOINCR par[2]
342:
343: #define CONSTINIT const[0]
344: #define CONSTLIMIT const[1]
345: #define CONSTINCR const[2]
346:
347: #define VARSTEP 0
348: #define POSSTEP 1
349: #define NEGSTEP 2
350:
351:
352: exdo(range, spec)
353: int range;
354: chainp spec;
355:
356: {
357: register expptr p, q;
358: expptr q1;
359: register Namep np;
360: chainp cp;
361: register int i;
362: int dotype, incsign;
363: Addrp dovarp, dostgp;
364: expptr par[3];
365: expptr const[3];
366: Slotp doslot;
367:
368: pushctl(CTLDO);
369: dorange = ctlstack->dolabel = range;
370: np = (Namep) (spec->datap);
371: ctlstack->donamep = NULL;
372: if(np->vdovar)
373: {
374: errstr("nested loops with variable %s", varstr(VL,np->varname));
375: return;
376: }
377:
378: dovarp = mkplace(np);
379: if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) )
380: {
381: err("bad type on DO variable");
382: return;
383: }
384:
385: ctlstack->donamep = np;
386:
387: np->vdovar = YES;
388: if( !optimflag && enregister(np) )
389: {
390: /* stgp points to a storage version, varp to a register version */
391: dostgp = dovarp;
392: dovarp = mkplace(np);
393: }
394: else
395: dostgp = NULL;
396: dotype = dovarp->vtype;
397:
398:
399: for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
400: {
401: p = fixtype((expptr) cpexpr((tagptr) q = cp->datap));
402: if(!ONEOF(p->headblock.vtype, MSKINT|MSKREAL) )
403: {
404: err("bad type on DO parameter");
405: return;
406: }
407:
408:
409: if (ISCONST(q))
410: const[i] = mkconv(dotype, q);
411: else
412: {
413: frexpr(q);
414: const[i] = NULL;
415: }
416:
417: par[i++] = mkconv(dotype, p);
418: }
419:
420: frchain(&spec);
421: switch(i)
422: {
423: case 0:
424: case 1:
425: err("too few DO parameters");
426: return;
427:
428: case 2:
429: DOINCR = (expptr) ICON(1);
430: CONSTINCR = ICON(1);
431:
432: case 3:
433: break;
434:
435: default:
436: err("too many DO parameters");
437: return;
438: }
439:
440:
441: for (i = 0; i < 4; i++)
442: ctlstack->ctlabels[i] = newlabel();
443:
444: if( CONSTLIMIT )
445: ctlstack->domax = DOLIMIT;
446: else
447: ctlstack->domax = (expptr) mktemp(dotype, PNULL);
448:
449: if( CONSTINCR )
450: {
451: ctlstack->dostep = DOINCR;
452: if( (incsign = conssgn(CONSTINCR)) == 0)
453: err("zero DO increment");
454: ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
455: }
456: else
457: {
458: ctlstack->dostep = (expptr) mktemp(dotype, PNULL);
459: ctlstack->dostepsign = VARSTEP;
460: }
461:
462: if (optimflag)
463: doslot = optbuff (SKDOHEAD,0,0,ctlstack);
464:
465: if( CONSTLIMIT && CONSTINIT && ctlstack->dostepsign!=VARSTEP)
466: {
467: if (optimflag)
468: optbuff (SKEQ,mkexpr(OPASSIGN,cpexpr(dovarp),cpexpr(DOINIT)),
469: 0,0);
470: else
471: puteq (cpexpr(dovarp), cpexpr(DOINIT));
472: if( ! onetripflag )
473: {
474: q = mkexpr(OPMINUS, cpexpr(CONSTLIMIT), cpexpr(CONSTINIT));
475: if((incsign * conssgn(q)) == -1)
476: {
477: warn("DO range never executed");
478: if (optimflag)
479: optbuff (SKGOTO,0,ctlstack->endlabel,0);
480: else
481: putgoto (ctlstack->endlabel);
482: }
483: frexpr(q);
484: }
485: }
486:
487:
488: else if (ctlstack->dostepsign != VARSTEP && !onetripflag)
489: {
490: if (CONSTLIMIT)
491: q = (expptr) cpexpr(ctlstack->domax);
492: else
493: q = mkexpr(OPASSIGN, cpexpr(ctlstack->domax), DOLIMIT);
494: q1 = mkexpr(OPASSIGN, cpexpr(dovarp), DOINIT);
495: q = mkexpr( (ctlstack->dostepsign == POSSTEP ? OPLE : OPGE),
496: q1, q);
497: if (optimflag)
498: optbuff (SKIFN,q, ctlstack->endlabel,0);
499: else
500: putif (q, ctlstack->endlabel);
501: }
502: else
503: {
504: if (!CONSTLIMIT)
505: if (optimflag)
506: optbuff (SKEQ,
507: mkexpr(OPASSIGN,cpexpr(ctlstack->domax),DOLIMIT),0,0);
508: else
509: puteq (cpexpr(ctlstack->domax), DOLIMIT);
510: q = DOINIT;
511: if (!onetripflag)
512: q = mkexpr(OPMINUS, q,
513: mkexpr(OPASSIGN, cpexpr(ctlstack->dostep),
514: DOINCR) );
515: if (optimflag)
516: optbuff (SKEQ,mkexpr(OPASSIGN,cpexpr(dovarp), q),0,0);
517: else
518: puteq (cpexpr(dovarp), q);
519: if (onetripflag && ctlstack->dostepsign == VARSTEP)
520: if (optimflag)
521: optbuff (SKEQ,
522: mkexpr(OPASSIGN,cpexpr(ctlstack->dostep),DOINCR),0,0);
523: else
524: puteq (cpexpr(ctlstack->dostep), DOINCR);
525: }
526:
527: if (ctlstack->dostepsign == VARSTEP)
528: {
529: expptr incr,test;
530: if (onetripflag)
531: if (optimflag)
532: optbuff (SKGOTO,0,ctlstack->dobodylabel,0);
533: else
534: putgoto (ctlstack->dobodylabel);
535: else
536: if (optimflag)
537: optbuff (SKIFN,mkexpr(OPGE, cpexpr(ctlstack->dostep), ICON(0)),
538: ctlstack->doneglabel,0);
539: else
540: putif (mkexpr(OPGE, cpexpr(ctlstack->dostep), ICON(0)),
541: ctlstack->doneglabel);
542: if (optimflag)
543: optbuff (SKLABEL,0,ctlstack->doposlabel,0);
544: else
545: putlabel (ctlstack->doposlabel);
546: incr = mkexpr(OPPLUSEQ, cpexpr(dovarp), cpexpr(ctlstack->dostep));
547: test = mkexpr(OPLE, incr, cpexpr(ctlstack->domax));
548: if (optimflag)
549: optbuff (SKIFN,test, ctlstack->endlabel,0);
550: else
551: putif (test, ctlstack->endlabel);
552: }
553:
554: if (optimflag)
555: optbuff (SKLABEL,0,ctlstack->dobodylabel,0);
556: else
557: putlabel (ctlstack->dobodylabel);
558: if (dostgp)
559: {
560: if (optimflag)
561: optbuff (SKEQ,mkexpr(OPASSIGN,dostgp, dovarp),0,0);
562: else
563: puteq (dostgp, dovarp);
564: }
565: else
566: frexpr(dovarp);
567: if (optimflag)
568: doslot->nullslot = optbuff (SKNULL,0,0,0);
569:
570: frexpr(CONSTINIT);
571: frexpr(CONSTLIMIT);
572: frexpr(CONSTINCR);
573: }
574:
575:
576: enddo(here)
577: int here;
578:
579: {
580: register struct Ctlframe *q;
581: Namep np;
582: Addrp ap, rv;
583: expptr t;
584: register int i;
585: Slotp doslot;
586:
587: while (here == dorange)
588: {
589: if (np = ctlstack->donamep)
590: {
591: rv = mkplace (np);
592:
593: t = mkexpr(OPPLUSEQ, cpexpr(rv), cpexpr(ctlstack->dostep) );
594:
595: if (optimflag)
596: doslot = optbuff (SKENDDO,0,0,ctlstack);
597:
598: if (ctlstack->dostepsign == VARSTEP)
599: if (optimflag)
600: {
601: optbuff (SKIFN,
602: mkexpr(OPLE, cpexpr(ctlstack->dostep), ICON(0)),
603: ctlstack->doposlabel,0);
604: optbuff (SKLABEL,0,ctlstack->doneglabel,0);
605: optbuff (SKIFN,mkexpr(OPLT, t, ctlstack->domax),
606: ctlstack->dobodylabel,0);
607: }
608: else
609: {
610: putif (mkexpr(OPLE, cpexpr(ctlstack->dostep), ICON(0)),
611: ctlstack->doposlabel);
612: putlabel (ctlstack->doneglabel);
613: putif (mkexpr(OPLT, t, ctlstack->domax),
614: ctlstack->dobodylabel);
615: }
616: else
617: {
618: int op;
619: op = (ctlstack->dostepsign == POSSTEP ? OPGT : OPLT);
620: if (optimflag)
621: optbuff (SKIFN, mkexpr(op,t,ctlstack->domax),
622: ctlstack->dobodylabel,0);
623: else
624: putif (mkexpr(op, t, ctlstack->domax),
625: ctlstack->dobodylabel);
626: }
627: if (optimflag)
628: optbuff (SKLABEL,0,ctlstack->endlabel,0);
629: else
630: putlabel (ctlstack->endlabel);
631:
632: if (ap = memversion(np))
633: {
634: if (optimflag)
635: optbuff (SKEQ,mkexpr(OPASSIGN,ap, rv),0,0);
636: else
637: puteq (ap, rv);
638: }
639: else
640: frexpr(rv);
641: for (i = 0; i < 4; i++)
642: ctlstack->ctlabels[i] = 0;
643: if (!optimflag)
644: deregister(ctlstack->donamep);
645: ctlstack->donamep->vdovar = NO;
646: if (optimflag)
647: doslot->nullslot = optbuff (SKNULL,0,0,0);
648: }
649:
650: popctl();
651: poplab();
652:
653: dorange = 0;
654: for (q = ctlstack; q >= ctls; --q)
655: if (q->ctltype == CTLDO)
656: {
657: dorange = q->dolabel;
658: break;
659: }
660: }
661: }
662:
663:
664: exassign(vname, labelval)
665: Namep vname;
666: struct Labelblock *labelval;
667: {
668: Addrp p;
669: expptr mkaddcon();
670:
671: p = mkplace(vname);
672: if( ! ONEOF(p->vtype, MSKINT|MSKADDR) )
673: err("noninteger assign variable");
674: else if (optimflag)
675: optbuff (SKASSIGN, p, labelval->labelno, 0);
676: else
677: puteq (p, mkaddcon(labelval->labelno) );
678: }
679:
680:
681:
682: exarif(expr, neglab, zerlab, poslab)
683: expptr expr;
684: struct Labelblock *neglab, *zerlab, *poslab;
685: {
686: register int lm, lz, lp;
687: struct Labelblock *labels[3];
688:
689: lm = neglab->labelno;
690: lz = zerlab->labelno;
691: lp = poslab->labelno;
692: expr = fixtype(expr);
693:
694: if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) )
695: {
696: err("invalid type of arithmetic if expression");
697: frexpr(expr);
698: }
699: else
700: {
701: if(lm == lz)
702: exar2(OPLE, expr, lm, lp);
703: else if(lm == lp)
704: exar2(OPNE, expr, lm, lz);
705: else if(lz == lp)
706: exar2(OPGE, expr, lz, lm);
707: else
708: if (optimflag)
709: {
710: labels[0] = neglab;
711: labels[1] = zerlab;
712: labels[2] = poslab;
713: optbuff (SKARIF, expr, 0, labels);
714: }
715: else
716: prarif(expr, lm, lz, lp);
717: }
718: }
719:
720:
721:
722: LOCAL exar2 (op, e, l1, l2)
723: int op;
724: expptr e;
725: int l1,l2;
726: {
727: if (optimflag)
728: {
729: optbuff (SKIFN, mkexpr(op, e, ICON(0)), l2, 0);
730: optbuff (SKGOTO, 0, l1, 0);
731: }
732: else
733: {
734: putif (mkexpr(op, e, ICON(0)), l2);
735: putgoto (l1);
736: }
737: }
738:
739:
740: exreturn(p)
741: register expptr p;
742: {
743: if(procclass != CLPROC)
744: warn("RETURN statement in main or block data");
745: if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
746: {
747: err("alternate return in nonsubroutine");
748: p = 0;
749: }
750:
751: if(p)
752: if (optimflag)
753: optbuff (SKRETURN, p, retlabel, 0);
754: else
755: {
756: putforce (TYINT, p);
757: putgoto (retlabel);
758: }
759: else
760: if (optimflag)
761: optbuff (SKRETURN, p,
762: (proctype==TYSUBR ? ret0label : retlabel), 0);
763: else
764: putgoto (proctype==TYSUBR ? ret0label : retlabel);
765: }
766:
767:
768:
769: exasgoto(labvar)
770: struct Hashentry *labvar;
771: {
772: register Addrp p;
773:
774: p = mkplace(labvar);
775: if( ! ISINT(p->vtype) )
776: err("assigned goto variable must be integer");
777: else
778: if (optimflag)
779: optbuff (SKASGOTO, p, 0, 0);
780: else
781: putbranch (p);
782: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.