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