|
|
1.1 root 1: /****************************************************************
2: Copyright 1990, 1993 by AT&T Bell Laboratories and Bellcore.
3:
4: Permission to use, copy, modify, and distribute this software
5: and its documentation for any purpose and without fee is hereby
6: granted, provided that the above copyright notice appear in all
7: copies and that both that the copyright notice and this
8: permission notice and warranty disclaimer appear in supporting
9: documentation, and that the names of AT&T Bell Laboratories or
10: Bellcore or any of their entities not be used in advertising or
11: publicity pertaining to distribution of the software without
12: specific, written prior permission.
13:
14: AT&T and Bellcore disclaim all warranties with regard to this
15: software, including all implied warranties of merchantability
16: and fitness. In no event shall AT&T or Bellcore be liable for
17: any special, indirect or consequential damages or any damages
18: whatsoever resulting from loss of use, data or profits, whether
19: in an action of contract, negligence or other tortious action,
20: arising out of or in connection with the use or performance of
21: this software.
22: ****************************************************************/
23:
24: #include "defs.h"
25: #include "p1defs.h"
26: #include "names.h"
27:
28: LOCAL void exar2(), popctl(), pushctl();
29:
30: /* Logical IF codes
31: */
32:
33:
34: exif(p)
35: expptr p;
36: {
37: pushctl(CTLIF);
38: putif(p, 0); /* 0 => if, not elseif */
39: }
40:
41:
42:
43: exelif(p)
44: expptr p;
45: {
46: if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
47: putif(p, 1); /* 1 ==> elseif */
48: else
49: execerr("elseif out of place", CNULL);
50: }
51:
52:
53:
54:
55:
56: exelse()
57: {
58: register struct Ctlframe *c;
59:
60: for(c = ctlstack; c->ctltype == CTLIFX; --c);
61: if(c->ctltype == CTLIF) {
62: p1_else ();
63: c->ctltype = CTLELSE;
64: }
65: else
66: execerr("else out of place", CNULL);
67: }
68:
69:
70: exendif()
71: {
72: while(ctlstack->ctltype == CTLIFX) {
73: popctl();
74: p1else_end();
75: }
76: if(ctlstack->ctltype == CTLIF) {
77: popctl();
78: p1_endif ();
79: }
80: else if(ctlstack->ctltype == CTLELSE) {
81: popctl();
82: p1else_end ();
83: }
84: else
85: execerr("endif out of place", CNULL);
86: }
87:
88:
89: new_endif()
90: {
91: if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
92: pushctl(CTLIFX);
93: else
94: err("new_endif bug");
95: }
96:
97: /* pushctl -- Start a new control construct, initialize the labels (to
98: zero) */
99:
100: LOCAL void
101: pushctl(code)
102: int code;
103: {
104: register int i;
105:
106: if(++ctlstack >= lastctl)
107: many("loops or if-then-elses", 'c', maxctl);
108: ctlstack->ctltype = code;
109: for(i = 0 ; i < 4 ; ++i)
110: ctlstack->ctlabels[i] = 0;
111: ctlstack->dowhile = 0;
112: ++blklevel;
113: }
114:
115:
116: LOCAL void
117: popctl()
118: {
119: if( ctlstack-- < ctls )
120: Fatal("control stack empty");
121: --blklevel;
122: }
123:
124:
125:
126: /* poplab -- update the flags in labeltab */
127:
128: LOCAL poplab()
129: {
130: register struct Labelblock *lp;
131:
132: for(lp = labeltab ; lp < highlabtab ; ++lp)
133: if(lp->labdefined)
134: {
135: /* mark all labels in inner blocks unreachable */
136: if(lp->blklevel > blklevel)
137: lp->labinacc = YES;
138: }
139: else if(lp->blklevel > blklevel)
140: {
141: /* move all labels referred to in inner blocks out a level */
142: lp->blklevel = blklevel;
143: }
144: }
145:
146:
147: /* BRANCHING CODE
148: */
149:
150: exgoto(lab)
151: struct Labelblock *lab;
152: {
153: lab->labused = 1;
154: p1_goto (lab -> stateno);
155: }
156:
157:
158:
159:
160:
161:
162:
163: exequals(lp, rp)
164: register struct Primblock *lp;
165: register expptr rp;
166: {
167: if(lp->tag != TPRIM)
168: {
169: err("assignment to a non-variable");
170: frexpr((expptr)lp);
171: frexpr(rp);
172: }
173: else if(lp->namep->vclass!=CLVAR && lp->argsp)
174: {
175: if(parstate >= INEXEC)
176: err("statement function amid executables");
177: mkstfunct(lp, rp);
178: }
179: else
180: {
181: expptr new_lp, new_rp;
182:
183: if(parstate < INDATA)
184: enddcl();
185: new_lp = mklhs (lp, keepsubs);
186: new_rp = fixtype (rp);
187: puteq(new_lp, new_rp);
188: }
189: }
190:
191:
192:
193: /* Make Statement Function */
194:
195: long laststfcn = -1, thisstno;
196: int doing_stmtfcn;
197:
198: mkstfunct(lp, rp)
199: struct Primblock *lp;
200: expptr rp;
201: {
202: register struct Primblock *p;
203: register Namep np;
204: chainp args;
205:
206: laststfcn = thisstno;
207: np = lp->namep;
208: if(np->vclass == CLUNKNOWN)
209: np->vclass = CLPROC;
210: else
211: {
212: dclerr("redeclaration of statement function", np);
213: return;
214: }
215: np->vprocclass = PSTFUNCT;
216: np->vstg = STGSTFUNCT;
217:
218: /* Set the type of the function */
219:
220: impldcl(np);
221: if (np->vtype == TYCHAR && !np->vleng)
222: err("character statement function with length (*)");
223: args = (lp->argsp ? lp->argsp->listp : CHNULL);
224: np->varxptr.vstfdesc = mkchain((char *)args, (chainp)rp);
225:
226: for(doing_stmtfcn = 1 ; args ; args = args->nextp)
227:
228: /* It is an error for the formal parameters to have arguments or
229: subscripts */
230:
231: if( ((tagptr)(args->datap))->tag!=TPRIM ||
232: (p = (struct Primblock *)(args->datap) )->argsp ||
233: p->fcharp || p->lcharp )
234: err("non-variable argument in statement function definition");
235: else
236: {
237:
238: /* Replace the name on the left-hand side */
239:
240: args->datap = (char *)p->namep;
241: vardcl(p -> namep);
242: free((char *)p);
243: }
244: doing_stmtfcn = 0;
245: }
246:
247: static void
248: mixed_type(np)
249: Namep np;
250: {
251: char buf[128];
252: sprintf(buf, "%s function %.90s invoked as subroutine",
253: ftn_types[np->vtype], np->fvarname);
254: warn(buf);
255: }
256:
257:
258: excall(name, args, nstars, labels)
259: Namep name;
260: struct Listblock *args;
261: int nstars;
262: struct Labelblock *labels[ ];
263: {
264: register expptr p;
265:
266: if (name->vtype != TYSUBR) {
267: if (name->vinfproc && !name->vcalled) {
268: name->vtype = TYSUBR;
269: frexpr(name->vleng);
270: name->vleng = 0;
271: }
272: else if (!name->vimpltype && name->vtype != TYUNKNOWN)
273: mixed_type(name);
274: else
275: settype(name, TYSUBR, (ftnint)0);
276: }
277: p = mkfunct( mkprim(name, args, CHNULL) );
278:
279: /* Subroutines and their identifiers acquire the type INT */
280:
281: p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
282:
283: /* Handle the alternate return mechanism */
284:
285: if(nstars > 0)
286: putcmgo(putx(fixtype(p)), nstars, labels);
287: else
288: putexpr(p);
289: }
290:
291:
292:
293: exstop(stop, p)
294: int stop;
295: register expptr p;
296: {
297: char *str;
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: str = convic(p->constblock.Const.ci);
312: n = strlen(str);
313: if(n > 0)
314: {
315: p->constblock.Const.ccp = copyn(n, str);
316: p->constblock.Const.ccp1.blanks = 0;
317: p->constblock.vtype = TYCHAR;
318: p->constblock.vleng = (expptr) ICON(n);
319: }
320: else
321: p = (expptr) mkstrcon(0, CNULL);
322: }
323: else if(p->constblock.vtype != TYCHAR)
324: {
325: execerr("pause/stop argument must be integer or string", CNULL);
326: p = (expptr) mkstrcon(0, CNULL);
327: }
328: }
329: else p = (expptr) mkstrcon(0, CNULL);
330:
331: {
332: expptr subr_call;
333:
334: subr_call = call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p);
335: putexpr( subr_call );
336: }
337: }
338:
339: /* DO LOOP CODE */
340:
341: #define DOINIT par[0]
342: #define DOLIMIT par[1]
343: #define DOINCR par[2]
344:
345:
346: /* Macros for ctlstack -> dostepsign */
347:
348: #define VARSTEP 0
349: #define POSSTEP 1
350: #define NEGSTEP 2
351:
352:
353: /* exdo -- generate DO loop code. In the case of a variable increment,
354: positive increment tests are placed above the body, negative increment
355: tests are placed below (see enddo() ) */
356:
357: exdo(range, loopname, spec)
358: int range; /* end label */
359: Namep loopname;
360: chainp spec; /* input spec must have at least 2 exprs */
361: {
362: register expptr p;
363: register Namep np;
364: chainp cp; /* loops over the fields in spec */
365: register int i;
366: int dotype; /* type of the index variable */
367: int incsign; /* sign of the increment, if it's constant
368: */
369: Addrp dovarp; /* loop index variable */
370: expptr doinit; /* constant or register for init param */
371: expptr par[3]; /* local specification parameters */
372:
373: expptr init, test, inc; /* Expressions in the resulting FOR loop */
374:
375:
376: test = ENULL;
377:
378: pushctl(CTLDO);
379: dorange = ctlstack->dolabel = range;
380: ctlstack->loopname = loopname;
381:
382: /* Declare the loop index */
383:
384: np = (Namep)spec->datap;
385: ctlstack->donamep = NULL;
386: if (!np) { /* do while */
387: ctlstack->dowhile = 1;
388: #if 0
389: if (loopname) {
390: if (loopname->vtype == TYUNKNOWN) {
391: loopname->vdcldone = 1;
392: loopname->vclass = CLLABEL;
393: loopname->vprocclass = PLABEL;
394: loopname->vtype = TYLABEL;
395: }
396: if (loopname->vtype == TYLABEL)
397: if (loopname->vdovar)
398: dclerr("already in use as a loop name",
399: loopname);
400: else
401: loopname->vdovar = 1;
402: else
403: dclerr("already declared; cannot be a loop name",
404: loopname);
405: }
406: #endif
407: putwhile((expptr)spec->nextp);
408: NOEXT("do while");
409: spec->nextp = 0;
410: frchain(&spec);
411: return;
412: }
413: if(np->vdovar)
414: {
415: errstr("nested loops with variable %s", np->fvarname);
416: ctlstack->donamep = NULL;
417: return;
418: }
419:
420: /* Create a memory-resident version of the index variable */
421:
422: dovarp = mkplace(np);
423: if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) )
424: {
425: err("bad type on do variable");
426: return;
427: }
428: ctlstack->donamep = np;
429:
430: np->vdovar = YES;
431:
432: /* Now dovarp points to the index to be used within the loop, dostgp
433: points to the one which may need to be stored */
434:
435: dotype = dovarp->vtype;
436:
437: /* Count the input specifications and type-check each one independently;
438: this just eliminates non-numeric values from the specification */
439:
440: for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
441: {
442: p = par[i++] = fixtype((tagptr)cp->datap);
443: if( ! ONEOF(p->headblock.vtype, MSKINT|MSKREAL) )
444: {
445: err("bad type on DO parameter");
446: return;
447: }
448: }
449:
450: frchain(&spec);
451: switch(i)
452: {
453: case 0:
454: case 1:
455: err("too few DO parameters");
456: return;
457:
458: default:
459: err("too many DO parameters");
460: return;
461:
462: case 2:
463: DOINCR = (expptr) ICON(1);
464:
465: case 3:
466: break;
467: }
468:
469:
470: /* Now all of the local specification fields are set, but their types are
471: not yet consistent */
472:
473: /* Declare the loop initialization value, casting it properly and declaring a
474: register if need be */
475:
476: if (ISCONST (DOINIT) || !onetripflag)
477: /* putx added 6-29-89 (mwm), not sure if fixtype is required, but I doubt it
478: since mkconv is called just before */
479: doinit = putx (mkconv (dotype, DOINIT));
480: else {
481: doinit = (expptr) mktmp(dotype, ENULL);
482: puteq (cpexpr (doinit), DOINIT);
483: } /* else */
484:
485: /* Declare the loop ending value, casting it to the type of the index
486: variable */
487:
488: if( ISCONST(DOLIMIT) )
489: ctlstack->domax = mkconv(dotype, DOLIMIT);
490: else {
491: ctlstack->domax = (expptr) mktmp0(dotype, ENULL);
492: puteq (cpexpr (ctlstack -> domax), DOLIMIT);
493: } /* else */
494:
495: /* Declare the loop increment value, casting it to the type of the index
496: variable */
497:
498: if( ISCONST(DOINCR) )
499: {
500: ctlstack->dostep = mkconv(dotype, DOINCR);
501: if( (incsign = conssgn(ctlstack->dostep)) == 0)
502: err("zero DO increment");
503: ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
504: }
505: else
506: {
507: ctlstack->dostep = (expptr) mktmp0(dotype, ENULL);
508: ctlstack->dostepsign = VARSTEP;
509: puteq (cpexpr (ctlstack -> dostep), DOINCR);
510: }
511:
512: /* All data is now properly typed and in the ctlstack, except for the
513: initial value. Assignments of temps have been generated already */
514:
515: switch (ctlstack -> dostepsign) {
516: case VARSTEP:
517: test = mkexpr (OPQUEST, mkexpr (OPLT,
518: cpexpr (ctlstack -> dostep), ICON(0)),
519: mkexpr (OPCOLON,
520: mkexpr (OPGE, cpexpr((expptr)dovarp),
521: cpexpr (ctlstack -> domax)),
522: mkexpr (OPLE, cpexpr((expptr)dovarp),
523: cpexpr (ctlstack -> domax))));
524: break;
525: case POSSTEP:
526: test = mkexpr (OPLE, cpexpr((expptr)dovarp),
527: cpexpr (ctlstack -> domax));
528: break;
529: case NEGSTEP:
530: test = mkexpr (OPGE, cpexpr((expptr)dovarp),
531: cpexpr (ctlstack -> domax));
532: break;
533: default:
534: erri ("exdo: bad dostepsign '%d'", ctlstack -> dostepsign);
535: break;
536: } /* switch (ctlstack -> dostepsign) */
537:
538: if (onetripflag)
539: test = mkexpr (OPOR, test,
540: mkexpr (OPEQ, cpexpr((expptr)dovarp), cpexpr (doinit)));
541: init = mkexpr (OPASSIGN, cpexpr((expptr)dovarp), doinit);
542: inc = mkexpr (OPPLUSEQ, (expptr)dovarp, cpexpr (ctlstack -> dostep));
543:
544: if (!onetripflag && ISCONST (ctlstack -> domax) && ISCONST (doinit)
545: && ctlstack -> dostepsign != VARSTEP) {
546: expptr tester;
547:
548: tester = mkexpr (OPMINUS, cpexpr (doinit),
549: cpexpr (ctlstack -> domax));
550: if (incsign == conssgn (tester))
551: warn ("DO range never executed");
552: frexpr (tester);
553: } /* if !onetripflag && */
554:
555: p1_for (init, test, inc);
556: }
557:
558: exenddo(np)
559: Namep np;
560: {
561: Namep np1;
562: int here;
563: struct Ctlframe *cf;
564:
565: if( ctlstack < ctls )
566: Fatal("control stack empty");
567: here = ctlstack->dolabel;
568: if (ctlstack->ctltype != CTLDO
569: || here >= 0 && (!thislabel || thislabel->labelno != here)) {
570: err("misplaced ENDDO");
571: return;
572: }
573: if (np != ctlstack->loopname) {
574: if (np1 = ctlstack->loopname)
575: errstr("expected \"enddo %s\"", np1->fvarname);
576: else
577: err("expected unnamed ENDDO");
578: for(cf = ctls; cf < ctlstack; cf++)
579: if (cf->ctltype == CTLDO && cf->loopname == np) {
580: here = cf->dolabel;
581: break;
582: }
583: }
584: enddo(here);
585: }
586:
587:
588: enddo(here)
589: int here;
590: {
591: register struct Ctlframe *q;
592: Namep np; /* name of the current DO index */
593: Addrp ap;
594: register int i;
595: register expptr e;
596:
597: /* Many DO's can end at the same statement, so keep looping over all
598: nested indicies */
599:
600: while(here == dorange)
601: {
602: if(np = ctlstack->donamep)
603: {
604: p1for_end ();
605:
606: /* Now we're done with all of the tests, and the loop has terminated.
607: Store the index value back in long-term memory */
608:
609: if(ap = memversion(np))
610: puteq((expptr)ap, (expptr)mkplace(np));
611: for(i = 0 ; i < 4 ; ++i)
612: ctlstack->ctlabels[i] = 0;
613: deregister(ctlstack->donamep);
614: ctlstack->donamep->vdovar = NO;
615: e = ctlstack->dostep;
616: if (e->tag == TADDR && e->addrblock.istemp)
617: frtemp((Addrp)e);
618: else
619: frexpr(e);
620: e = ctlstack->domax;
621: if (e->tag == TADDR && e->addrblock.istemp)
622: frtemp((Addrp)e);
623: else
624: frexpr(e);
625: }
626: else if (ctlstack->dowhile)
627: p1for_end ();
628:
629: /* Set dorange to the closing label of the next most enclosing DO loop
630: */
631:
632: popctl();
633: poplab();
634: dorange = 0;
635: for(q = ctlstack ; q>=ctls ; --q)
636: if(q->ctltype == CTLDO)
637: {
638: dorange = q->dolabel;
639: break;
640: }
641: }
642: }
643:
644: exassign(vname, labelval)
645: register Namep vname;
646: struct Labelblock *labelval;
647: {
648: Addrp p;
649: expptr mkaddcon();
650: register Addrp q;
651: char *fs;
652: register chainp cp, cpprev;
653: register ftnint k, stno;
654:
655: p = mkplace(vname);
656: if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) {
657: err("noninteger assign variable");
658: return;
659: }
660:
661: /* If the label hasn't been defined, then we do things twice:
662: * once for an executable stmt label, once for a format
663: */
664:
665: /* code for executable label... */
666:
667: /* Now store the assigned value in a list associated with this variable.
668: This will be used later to generate a switch() statement in the C output */
669:
670: fs = labelval->fmtstring;
671: if (!labelval->labdefined || !fs) {
672:
673: if (vname -> vis_assigned == 0) {
674: vname -> varxptr.assigned_values = CHNULL;
675: vname -> vis_assigned = 1;
676: }
677:
678: /* don't duplicate labels... */
679:
680: stno = labelval->stateno;
681: cpprev = 0;
682: for(k = 0, cp = vname->varxptr.assigned_values;
683: cp; cpprev = cp, cp = cp->nextp, k++)
684: if ((ftnint)cp->datap == stno)
685: break;
686: if (!cp) {
687: cp = mkchain((char *)stno, CHNULL);
688: if (cpprev)
689: cpprev->nextp = cp;
690: else
691: vname->varxptr.assigned_values = cp;
692: labelval->labused = 1;
693: }
694: putout(mkexpr(OPASSIGN, (expptr)p, mkintcon(k)));
695: }
696:
697: /* Code for FORMAT label... */
698:
699: if (!labelval->labdefined || fs) {
700: extern void fmtname();
701:
702: labelval->fmtlabused = 1;
703: p = ALLOC(Addrblock);
704: p->tag = TADDR;
705: p->vtype = TYCHAR;
706: p->vstg = STGAUTO;
707: p->memoffset = ICON(0);
708: fmtname(vname, p);
709: q = ALLOC(Addrblock);
710: q->tag = TADDR;
711: q->vtype = TYCHAR;
712: q->vstg = STGAUTO;
713: q->ntempelt = 1;
714: q->memoffset = ICON(0);
715: q->uname_tag = UNAM_IDENT;
716: sprintf(q->user.ident, "fmt_%ld", labelval->stateno);
717: putout(mkexpr(OPASSIGN, (expptr)p, (expptr)q));
718: }
719:
720: } /* exassign */
721:
722:
723:
724: exarif(expr, neglab, zerlab, poslab)
725: expptr expr;
726: struct Labelblock *neglab, *zerlab, *poslab;
727: {
728: register int lm, lz, lp;
729:
730: lm = neglab->stateno;
731: lz = zerlab->stateno;
732: lp = poslab->stateno;
733: expr = fixtype(expr);
734:
735: if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) )
736: {
737: err("invalid type of arithmetic if expression");
738: frexpr(expr);
739: }
740: else
741: {
742: if (lm == lz && lz == lp)
743: exgoto (neglab);
744: else if(lm == lz)
745: exar2(OPLE, expr, neglab, poslab);
746: else if(lm == lp)
747: exar2(OPNE, expr, neglab, zerlab);
748: else if(lz == lp)
749: exar2(OPGE, expr, zerlab, neglab);
750: else {
751: expptr t;
752:
753: if (!addressable (expr)) {
754: t = (expptr) mktmp(expr -> headblock.vtype, ENULL);
755: expr = mkexpr (OPASSIGN, cpexpr (t), expr);
756: } else
757: t = (expptr) cpexpr (expr);
758:
759: p1_if(putx(fixtype(mkexpr (OPLT, expr, ICON (0)))));
760: exgoto(neglab);
761: p1_elif (mkexpr (OPEQ, t, ICON (0)));
762: exgoto(zerlab);
763: p1_else ();
764: exgoto(poslab);
765: p1else_end ();
766: } /* else */
767: }
768: }
769:
770:
771:
772: /* exar2 -- Do arithmetic IF for only 2 distinct labels; if !(e.op.0)
773: goto l2 else goto l1. If this seems backwards, that's because it is,
774: in order to make the 1 pass algorithm work. */
775:
776: LOCAL void
777: exar2(op, e, l1, l2)
778: int op;
779: expptr e;
780: struct Labelblock *l1, *l2;
781: {
782: expptr comp;
783:
784: comp = mkexpr (op, e, ICON (0));
785: p1_if(putx(fixtype(comp)));
786: exgoto(l1);
787: p1_else ();
788: exgoto(l2);
789: p1else_end ();
790: }
791:
792:
793: /* exreturn -- return the value in p from a SUBROUTINE call -- used to
794: implement the alternate return mechanism */
795:
796: exreturn(p)
797: register expptr p;
798: {
799: if(procclass != CLPROC)
800: warn("RETURN statement in main or block data");
801: if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
802: {
803: err("alternate return in nonsubroutine");
804: p = 0;
805: }
806:
807: if (p || proctype == TYSUBR) {
808: if (p == ENULL) p = ICON (0);
809: p = mkconv (TYLONG, fixtype (p));
810: p1_subr_ret (p);
811: } /* if p || proctype == TYSUBR */
812: else
813: p1_subr_ret((expptr)retslot);
814: }
815:
816:
817: exasgoto(labvar)
818: Namep labvar;
819: {
820: register Addrp p;
821: void p1_asgoto();
822:
823: p = mkplace(labvar);
824: if( ! ISINT(p->vtype) )
825: err("assigned goto variable must be integer");
826: else {
827: p1_asgoto (p);
828: } /* else */
829: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.