![[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 [Research Unix] / researchv10no / cmd / f77|
Return to exec.c CVS log | Up to [Research Unix] / researchv10no / cmd / f77 |
1.1 root 1: #include "defs"
2:
3: LOCAL int exar2(), popctl(), pushctl();
4:
5: /* Logical IF codes
6: */
7:
8:
9: exif(p)
10: expptr p;
11: {
12: pushctl(CTLIF);
13: ctlstack->elselabel = newlabel();
14: putif(p, ctlstack->elselabel);
15: }
16:
17:
18:
19: exelif(p)
20: expptr p;
21: {
22: if(ctlstack->ctltype == CTLIF)
23: {
24: if(ctlstack->endlabel == 0)
25: ctlstack->endlabel = newlabel();
26: putgoto(ctlstack->endlabel);
27: putlabel(ctlstack->elselabel);
28: ctlstack->elselabel = newlabel();
29: putif(p, ctlstack->elselabel);
30: }
31:
32: else execerr("elseif out of place", CNULL);
33: }
34:
35:
36:
37:
38:
39: exelse()
40: {
41: if(ctlstack->ctltype==CTLIF)
42: {
43: if(ctlstack->endlabel == 0)
44: ctlstack->endlabel = newlabel();
45: putgoto( ctlstack->endlabel );
46: putlabel(ctlstack->elselabel);
47: ctlstack->ctltype = CTLELSE;
48: }
49:
50: else execerr("else out of place", CNULL);
51: }
52:
53:
54: exendif()
55: {
56: if(ctlstack->ctltype == CTLIF)
57: {
58: putlabel(ctlstack->elselabel);
59: if(ctlstack->endlabel)
60: putlabel(ctlstack->endlabel);
61: popctl();
62: }
63: else if(ctlstack->ctltype == CTLELSE)
64: {
65: putlabel(ctlstack->endlabel);
66: popctl();
67: }
68:
69: else
70: execerr("endif out of place", CNULL);
71: }
72:
73:
74:
75: LOCAL pushctl(code)
76: int code;
77: {
78: register int i;
79:
80: if(++ctlstack >= lastctl)
81: many("loops or if-then-elses", 'c', maxctl);
82: ctlstack->ctltype = code;
83: for(i = 0 ; i < 4 ; ++i)
84: ctlstack->ctlabels[i] = 0;
85: ++blklevel;
86: }
87:
88:
89: LOCAL popctl()
90: {
91: if( ctlstack-- < ctls )
92: fatal("control stack empty");
93: --blklevel;
94: }
95:
96:
97:
98: LOCAL poplab()
99: {
100: register struct Labelblock *lp;
101:
102: for(lp = labeltab ; lp < highlabtab ; ++lp)
103: if(lp->labdefined)
104: {
105: /* mark all labels in inner blocks unreachable */
106: if(lp->blklevel > blklevel)
107: lp->labinacc = YES;
108: }
109: else if(lp->blklevel > blklevel)
110: {
111: /* move all labels referred to in inner blocks out a level */
112: lp->blklevel = blklevel;
113: }
114: }
115:
116:
117:
118: /* BRANCHING CODE
119: */
120:
121: exgoto(lab)
122: struct Labelblock *lab;
123: {
124: putgoto(lab->labelno);
125: }
126:
127:
128:
129:
130:
131:
132:
133: exequals(lp, rp)
134: register struct Primblock *lp;
135: register expptr rp;
136: {
137: if(lp->tag != TPRIM)
138: {
139: err("assignment to a non-variable");
140: frexpr(lp);
141: frexpr(rp);
142: }
143: else if(lp->namep->vclass!=CLVAR && lp->argsp)
144: {
145: if(parstate >= INEXEC)
146: err("statement function amid executables");
147: else
148: mkstfunct(lp, rp);
149: }
150: else
151: {
152: if(parstate < INDATA)
153: enddcl();
154: puteq(mklhs(lp), fixtype(rp));
155: }
156: }
157:
158:
159: long laststfcn = -1, thisstno;
160:
161: mkstfunct(lp, rp)
162: struct Primblock *lp;
163: expptr rp;
164: {
165: register struct Primblock *p;
166: register Namep np;
167: chainp args;
168:
169: laststfcn = thisstno;
170: np = lp->namep;
171: if(np->vclass == CLUNKNOWN)
172: np->vclass = CLPROC;
173: else
174: {
175: dclerr("redeclaration of statement function", np);
176: return;
177: }
178: np->vprocclass = PSTFUNCT;
179: np->vstg = STGSTFUNCT;
180: impldcl(np);
181: args = (lp->argsp ? lp->argsp->listp : CHNULL);
182: np->varxptr.vstfdesc = mkchain(args , rp );
183:
184: for( ; args ; args = args->nextp)
185: if( args->datap->tag!=TPRIM ||
186: (p = (struct Primblock *) (args->datap) )->argsp ||
187: p->fcharp || p->lcharp )
188: err("non-variable argument in statement function definition");
189: else
190: {
191: args->datap = (tagptr) (p->namep);
192: vardcl(p->namep);
193: free(p);
194: }
195: }
196:
197:
198:
199: excall(name, args, nstars, labels)
200: Namep name;
201: struct Listblock *args;
202: int nstars;
203: struct Labelblock *labels[ ];
204: {
205: register expptr p;
206:
207: settype(name, TYSUBR, ENULL);
208: p = mkfunct( mkprim(name, args, CHNULL) );
209: p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
210: if(nstars > 0)
211: putcmgo(p, nstars, labels);
212: else putexpr(p);
213: }
214:
215:
216:
217: exstop(stop, p)
218: int stop;
219: register expptr p;
220: {
221: char *q;
222: int n;
223: expptr mkstrcon();
224:
225: if(p)
226: {
227: if( ! ISCONST(p) )
228: {
229: execerr("pause/stop argument must be constant", CNULL);
230: frexpr(p);
231: p = mkstrcon(0, CNULL);
232: }
233: else if( ISINT(p->constblock.vtype) )
234: {
235: q = convic(p->constblock.Const.ci);
236: n = strlen(q);
237: if(n > 0)
238: {
239: p->constblock.Const.ccp = copyn(n, q);
240: p->constblock.vtype = TYCHAR;
241: p->constblock.vleng = (expptr) ICON(n);
242: }
243: else
244: p = (expptr) mkstrcon(0, CNULL);
245: }
246: else if(p->constblock.vtype != TYCHAR)
247: {
248: execerr("pause/stop argument must be integer or string", CNULL);
249: p = (expptr) mkstrcon(0, CNULL);
250: }
251: }
252: else p = (expptr) mkstrcon(0, CNULL);
253:
254: putexpr( call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p) );
255: }
256:
257: /* DO LOOP CODE */
258:
259: #define DOINIT par[0]
260: #define DOLIMIT par[1]
261: #define DOINCR par[2]
262:
263: #define VARSTEP 0
264: #define POSSTEP 1
265: #define NEGSTEP 2
266:
267:
268: exdo(range, spec)
269: int range;
270: chainp spec;
271: {
272: register expptr p, q;
273: expptr q1;
274: register Namep np;
275: chainp cp;
276: register int i;
277: int dotype, incsign;
278: Addrp dovarp, dostgp;
279: expptr par[3];
280:
281: pushctl(CTLDO);
282: dorange = ctlstack->dolabel = range;
283: np = (Namep) (spec->datap);
284: ctlstack->donamep = NULL;
285: if(np->vdovar)
286: {
287: errstr("nested loops with variable %s", varstr(VL,np->varname));
288: ctlstack->donamep = NULL;
289: return;
290: }
291:
292: dovarp = mkplace(np);
293: if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) )
294: {
295: err("bad type on do variable");
296: return;
297: }
298: ctlstack->donamep = np;
299:
300: np->vdovar = YES;
301: if( enregister(np) )
302: {
303: /* stgp points to a storage version, varp to a register version */
304: dostgp = dovarp;
305: dovarp = mkplace(np);
306: }
307: else
308: dostgp = NULL;
309: dotype = dovarp->vtype;
310:
311: for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
312: {
313: p = par[i++] = fixtype(cp->datap);
314: if( ! ONEOF(p->headblock.vtype, MSKINT|MSKREAL) )
315: {
316: err("bad type on DO parameter");
317: return;
318: }
319: }
320:
321: frchain(&spec);
322: switch(i)
323: {
324: case 0:
325: case 1:
326: err("too few DO parameters");
327: return;
328:
329: default:
330: err("too many DO parameters");
331: return;
332:
333: case 2:
334: DOINCR = (expptr) ICON(1);
335:
336: case 3:
337: break;
338: }
339:
340: ctlstack->endlabel = newlabel();
341: ctlstack->dobodylabel = newlabel();
342:
343: if( ISCONST(DOLIMIT) )
344: ctlstack->domax = mkconv(dotype, DOLIMIT);
345: else
346: ctlstack->domax = (expptr) mktemp(dotype, PNULL);
347:
348: if( ISCONST(DOINCR) )
349: {
350: ctlstack->dostep = mkconv(dotype, DOINCR);
351: if( (incsign = conssgn(ctlstack->dostep)) == 0)
352: err("zero DO increment");
353: ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
354: }
355: else
356: {
357: ctlstack->dostep = (expptr) mktemp(dotype, PNULL);
358: ctlstack->dostepsign = VARSTEP;
359: ctlstack->doposlabel = newlabel();
360: ctlstack->doneglabel = newlabel();
361: }
362:
363: if( ISCONST(ctlstack->domax) && ISCONST(DOINIT) && ctlstack->dostepsign!=VARSTEP)
364: {
365: puteq(cpexpr(dovarp), cpexpr(DOINIT));
366: if( onetripflag )
367: frexpr(DOINIT);
368: else
369: {
370: q = mkexpr(OPMINUS, cpexpr(DOINIT),
371: cpexpr(ctlstack->domax));
372: if(incsign == (i = conssgn(q)) || !i && bugwarn & 2)
373: {
374: warn("DO range never executed");
375: putgoto(ctlstack->endlabel);
376: }
377: else if (!i && bugwarn)
378: warnb("old f77 never executed the DO range");
379: frexpr(q);
380: }
381: }
382: else if(ctlstack->dostepsign!=VARSTEP && !onetripflag)
383: {
384: if( ISCONST(ctlstack->domax) )
385: q = (expptr) cpexpr(ctlstack->domax);
386: else
387: q = mkexpr(OPASSIGN, cpexpr(ctlstack->domax), DOLIMIT);
388:
389: q1 = mkexpr(OPASSIGN, cpexpr(dovarp), DOINIT);
390: q = mkexpr( (ctlstack->dostepsign==POSSTEP ? OPLE : OPGE), q1, q);
391: putif(q, ctlstack->endlabel);
392: }
393: else
394: {
395: if(! ISCONST(ctlstack->domax) )
396: puteq( cpexpr(ctlstack->domax), DOLIMIT);
397: q = DOINIT;
398: if( ! onetripflag )
399: q = mkexpr(OPMINUS, q,
400: mkexpr(OPASSIGN, cpexpr(ctlstack->dostep), DOINCR) );
401: puteq( cpexpr(dovarp), q);
402: if(onetripflag && ctlstack->dostepsign==VARSTEP)
403: puteq( cpexpr(ctlstack->dostep), DOINCR);
404: }
405:
406: if(ctlstack->dostepsign == VARSTEP)
407: {
408: if(onetripflag)
409: putgoto(ctlstack->dobodylabel);
410: else
411: putif( mkexpr(OPGE, cpexpr(ctlstack->dostep), ICON(0)),
412: ctlstack->doneglabel );
413: putlabel(ctlstack->doposlabel);
414: putif( mkexpr(OPLE,
415: mkexpr(OPPLUSEQ, cpexpr(dovarp), cpexpr(ctlstack->dostep)),
416: cpexpr(ctlstack->domax) ),
417: ctlstack->endlabel);
418: }
419: putlabel(ctlstack->dobodylabel);
420: if(dostgp)
421: puteq(dostgp, cpexpr(dovarp));
422: frexpr(dovarp);
423: }
424:
425:
426:
427: enddo(here)
428: int here;
429: {
430: register struct Ctlframe *q;
431: register expptr t;
432: Namep np;
433: Addrp ap;
434: register int i;
435:
436: while(here == dorange)
437: {
438: if(np = ctlstack->donamep)
439: {
440: t = mkexpr(OPPLUSEQ, mkplace(ctlstack->donamep),
441: cpexpr(ctlstack->dostep) );
442:
443: if(ctlstack->dostepsign == VARSTEP)
444: {
445: putif( mkexpr(OPLE, cpexpr(ctlstack->dostep), ICON(0)), ctlstack->doposlabel);
446: putlabel(ctlstack->doneglabel);
447: putif( mkexpr(OPLT, t, ctlstack->domax), ctlstack->dobodylabel);
448: }
449: else
450: putif( mkexpr( (ctlstack->dostepsign==POSSTEP ? OPGT : OPLT),
451: t, ctlstack->domax),
452: ctlstack->dobodylabel);
453: putlabel(ctlstack->endlabel);
454: if(ap = memversion(np))
455: puteq(ap, mkplace(np));
456: for(i = 0 ; i < 4 ; ++i)
457: ctlstack->ctlabels[i] = 0;
458: deregister(ctlstack->donamep);
459: ctlstack->donamep->vdovar = NO;
460: frexpr(ctlstack->dostep);
461: }
462:
463: popctl();
464: poplab();
465: dorange = 0;
466: for(q = ctlstack ; q>=ctls ; --q)
467: if(q->ctltype == CTLDO)
468: {
469: dorange = q->dolabel;
470: break;
471: }
472: }
473: }
474:
475: chainp Lblfudgelist;
476:
477: expptr
478: labelfudge(t, newno)
479: register int t;
480: {
481: register chainp cp;
482: register Addrp A;
483:
484: for(cp = Lblfudgelist; cp; cp = cp->nextp->nextp)
485: if ((int)cp->datap == t)
486: break;
487: if (cp) {
488: A = (Addrp)cp->nextp->datap;
489: if (newno)
490: cp->datap = (tagptr)newno;
491: }
492: else {
493: if (newno)
494: return 0;
495: A = ALLOC(Addrblock);
496: A->tag = TADDR;
497: A->vtype = TYLONG;
498: A->vclass = CLVAR;
499: A->vstg = STGINIT;
500: A->memno = ++lastvarno;
501: A->memoffset = ICON(0);
502: Lblfudgelist = mkchain((tagptr)t,
503: mkchain((tagptr)A, Lblfudgelist));
504: }
505: return (expptr)cpexpr((tagptr)A);
506: }
507:
508: exassign(vname, labelval)
509: Namep vname;
510: struct Labelblock *labelval;
511: {
512: Addrp p;
513: expptr mkaddcon();
514:
515: p = mkplace(vname);
516: if( ! ONEOF(p->vtype, MSKINT|MSKADDR) )
517: err("noninteger assign variable");
518: else
519: puteq(p, labelval->labtype == LABUNKNOWN
520: ? labelfudge(labelval->labelno,0)
521: : mkaddcon(labelval->labelno) );
522: }
523:
524:
525:
526: exarif(expr, neglab, zerlab, poslab)
527: expptr expr;
528: struct Labelblock *neglab, *zerlab, *poslab;
529: {
530: register int lm, lz, lp;
531:
532: lm = neglab->labelno;
533: lz = zerlab->labelno;
534: lp = poslab->labelno;
535: expr = fixtype(expr);
536:
537: if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) )
538: {
539: err("invalid type of arithmetic if expression");
540: frexpr(expr);
541: }
542: else
543: {
544: if(lm == lz)
545: exar2(OPLE, expr, lm, lp);
546: else if(lm == lp)
547: exar2(OPNE, expr, lm, lz);
548: else if(lz == lp)
549: exar2(OPGE, expr, lz, lm);
550: else
551: prarif(expr, lm, lz, lp);
552: }
553: }
554:
555:
556:
557: LOCAL exar2(op, e, l1, l2)
558: int op;
559: expptr e;
560: int l1, l2;
561: {
562: putif( mkexpr(op, e, ICON(0)), l2);
563: putgoto(l1);
564: }
565:
566:
567: exreturn(p)
568: register expptr p;
569: {
570: if(procclass != CLPROC)
571: warn("RETURN statement in main or block data");
572: if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
573: {
574: err("alternate return in nonsubroutine");
575: p = 0;
576: }
577:
578: if(p)
579: {
580: putforce(TYINT, p);
581: putgoto(retlabel);
582: }
583: else
584: putgoto(proctype==TYSUBR ? ret0label : retlabel);
585: }
586:
587:
588:
589: exasgoto(labvar)
590: struct Hashentry *labvar;
591: {
592: register Addrp p;
593:
594: p = mkplace(labvar);
595: if( ! ISINT(p->vtype) )
596: err("assigned goto variable must be integer");
597: else
598: putbranch(p);
599: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.