1 /****************************************************************
2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
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.
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
22 ****************************************************************/
28 LOCAL void exar2(), popctl(), pushctl();
38 putif(p, 0); /* 0 => if, not elseif */
46 if (ctlstack->ctltype == CTLIF)
47 putif(p, 1); /* 1 ==> elseif */
49 execerr("elseif out of place", CNULL);
58 if(ctlstack->ctltype==CTLIF) {
60 ctlstack->ctltype = CTLELSE;
63 execerr("else out of place", CNULL);
69 if(ctlstack->ctltype == CTLIF) {
72 } else if(ctlstack->ctltype == CTLELSE) {
76 execerr("endif out of place", CNULL);
81 /* pushctl -- Start a new control construct, initialize the labels (to
90 if(++ctlstack >= lastctl)
91 many("loops or if-then-elses", 'c', maxctl);
92 ctlstack->ctltype = code;
93 for(i = 0 ; i < 4 ; ++i)
94 ctlstack->ctlabels[i] = 0;
95 ctlstack->dowhile = 0;
103 if( ctlstack-- < ctls )
104 Fatal("control stack empty");
110 /* poplab -- update the flags in labeltab */
114 register struct Labelblock *lp;
116 for(lp = labeltab ; lp < highlabtab ; ++lp)
119 /* mark all labels in inner blocks unreachable */
120 if(lp->blklevel > blklevel)
123 else if(lp->blklevel > blklevel)
125 /* move all labels referred to in inner blocks out a level */
126 lp->blklevel = blklevel;
135 struct Labelblock *lab;
138 p1_goto (lab -> stateno);
148 register struct Primblock *lp;
153 err("assignment to a non-variable");
157 else if(lp->namep->vclass!=CLVAR && lp->argsp)
159 if(parstate >= INEXEC)
160 err("statement function amid executables");
165 expptr new_lp, new_rp;
167 if(parstate < INDATA)
170 new_rp = fixtype (rp);
171 puteq(new_lp, new_rp);
177 /* Make Statement Function */
179 long laststfcn = -1, thisstno;
183 struct Primblock *lp;
186 register struct Primblock *p;
190 laststfcn = thisstno;
192 if(np->vclass == CLUNKNOWN)
196 dclerr("redeclaration of statement function", np);
199 np->vprocclass = PSTFUNCT;
200 np->vstg = STGSTFUNCT;
202 /* Set the type of the function */
205 args = (lp->argsp ? lp->argsp->listp : CHNULL);
206 np->varxptr.vstfdesc = mkchain((char *)args, (chainp)rp);
208 for(doing_stmtfcn = 1 ; args ; args = args->nextp)
210 /* It is an error for the formal parameters to have arguments or
213 if( ((tagptr)(args->datap))->tag!=TPRIM ||
214 (p = (struct Primblock *)(args->datap) )->argsp ||
215 p->fcharp || p->lcharp )
216 err("non-variable argument in statement function definition");
220 /* Replace the name on the left-hand side */
222 args->datap = (char *)p->namep;
234 sprintf(buf, "%s function %.90s invoked as subroutine",
235 ftn_types[np->vtype], np->fvarname);
240 excall(name, args, nstars, labels)
242 struct Listblock *args;
244 struct Labelblock *labels[ ];
247 extern void saveargtypes();
249 if (name->vtype != TYSUBR) {
250 if (name->vinfproc && !name->vcalled) {
251 name->vtype = TYSUBR;
255 else if (!name->vimpltype && name->vtype != TYUNKNOWN)
258 settype(name, TYSUBR, (ftnint)0);
260 p = mkfunct( mkprim(name, args, CHNULL) );
262 /* Subroutines and their identifiers acquire the type INT */
264 p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
266 /* Handle the alternate return mechanism */
269 saveargtypes((Exprp)p);
270 putcmgo(p, nstars, labels);
290 execerr("pause/stop argument must be constant", CNULL);
292 p = mkstrcon(0, CNULL);
294 else if( ISINT(p->constblock.vtype) )
296 str = convic(p->constblock.Const.ci);
300 p->constblock.Const.ccp = copyn(n, str);
301 p->constblock.Const.ccp1.blanks = 0;
302 p->constblock.vtype = TYCHAR;
303 p->constblock.vleng = (expptr) ICON(n);
306 p = (expptr) mkstrcon(0, CNULL);
308 else if(p->constblock.vtype != TYCHAR)
310 execerr("pause/stop argument must be integer or string", CNULL);
311 p = (expptr) mkstrcon(0, CNULL);
314 else p = (expptr) mkstrcon(0, CNULL);
319 subr_call = call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p);
320 putexpr( subr_call );
326 #define DOINIT par[0]
327 #define DOLIMIT par[1]
328 #define DOINCR par[2]
331 /* Macros for ctlstack -> dostepsign */
338 /* exdo -- generate DO loop code. In the case of a variable increment,
339 positive increment tests are placed above the body, negative increment
340 tests are placed below (see enddo() ) */
342 exdo(range, loopname, spec)
343 int range; /* end label */
345 chainp spec; /* input spec must have at least 2 exprs */
349 chainp cp; /* loops over the fields in spec */
351 int dotype; /* type of the index variable */
352 int incsign; /* sign of the increment, if it's constant
354 Addrp dovarp; /* loop index variable */
355 expptr doinit; /* constant or register for init param */
356 expptr par[3]; /* local specification parameters */
358 expptr init, test, inc; /* Expressions in the resulting FOR loop */
364 dorange = ctlstack->dolabel = range;
365 ctlstack->loopname = loopname;
367 /* Declare the loop index */
369 np = (Namep)spec->datap;
370 ctlstack->donamep = NULL;
371 if (!np) { /* do while */
372 ctlstack->dowhile = 1;
375 if (loopname->vtype == TYUNKNOWN) {
376 loopname->vdcldone = 1;
377 loopname->vclass = CLLABEL;
378 loopname->vprocclass = PLABEL;
379 loopname->vtype = TYLABEL;
381 if (loopname->vtype == TYLABEL)
382 if (loopname->vdovar)
383 dclerr("already in use as a loop name",
386 loopname->vdovar = 1;
388 dclerr("already declared; cannot be a loop name",
392 putwhile((expptr)spec->nextp);
400 errstr("nested loops with variable %s", np->fvarname);
401 ctlstack->donamep = NULL;
405 /* Create a memory-resident version of the index variable */
407 dovarp = mkplace(np);
408 if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) )
410 err("bad type on do variable");
413 ctlstack->donamep = np;
417 /* Now dovarp points to the index to be used within the loop, dostgp
418 points to the one which may need to be stored */
420 dotype = dovarp->vtype;
422 /* Count the input specifications and type-check each one independently;
423 this just eliminates non-numeric values from the specification */
425 for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
427 p = par[i++] = fixtype((tagptr)cp->datap);
428 if( ! ONEOF(p->headblock.vtype, MSKINT|MSKREAL) )
430 err("bad type on DO parameter");
440 err("too few DO parameters");
444 err("too many DO parameters");
448 DOINCR = (expptr) ICON(1);
455 /* Now all of the local specification fields are set, but their types are
456 not yet consistent */
458 /* Declare the loop initialization value, casting it properly and declaring a
459 register if need be */
461 if (ISCONST (DOINIT) || !onetripflag)
462 /* putx added 6-29-89 (mwm), not sure if fixtype is required, but I doubt it
463 since mkconv is called just before */
464 doinit = putx (mkconv (dotype, DOINIT));
466 doinit = (expptr) Mktemp(dotype, ENULL);
467 puteq (cpexpr (doinit), DOINIT);
470 /* Declare the loop ending value, casting it to the type of the index
473 if( ISCONST(DOLIMIT) )
474 ctlstack->domax = mkconv(dotype, DOLIMIT);
476 ctlstack->domax = (expptr) mktmp0(dotype, ENULL);
477 puteq (cpexpr (ctlstack -> domax), DOLIMIT);
480 /* Declare the loop increment value, casting it to the type of the index
483 if( ISCONST(DOINCR) )
485 ctlstack->dostep = mkconv(dotype, DOINCR);
486 if( (incsign = conssgn(ctlstack->dostep)) == 0)
487 err("zero DO increment");
488 ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
492 ctlstack->dostep = (expptr) mktmp0(dotype, ENULL);
493 ctlstack->dostepsign = VARSTEP;
494 puteq (cpexpr (ctlstack -> dostep), DOINCR);
497 /* All data is now properly typed and in the ctlstack, except for the
498 initial value. Assignments of temps have been generated already */
500 switch (ctlstack -> dostepsign) {
502 test = mkexpr (OPQUEST, mkexpr (OPLT,
503 cpexpr (ctlstack -> dostep), ICON(0)),
505 mkexpr (OPGE, cpexpr((expptr)dovarp),
506 cpexpr (ctlstack -> domax)),
507 mkexpr (OPLE, cpexpr((expptr)dovarp),
508 cpexpr (ctlstack -> domax))));
511 test = mkexpr (OPLE, cpexpr((expptr)dovarp),
512 cpexpr (ctlstack -> domax));
515 test = mkexpr (OPGE, cpexpr((expptr)dovarp),
516 cpexpr (ctlstack -> domax));
519 erri ("exdo: bad dostepsign '%d'", ctlstack -> dostepsign);
521 } /* switch (ctlstack -> dostepsign) */
524 test = mkexpr (OPOR, test,
525 mkexpr (OPEQ, cpexpr((expptr)dovarp), cpexpr (doinit)));
526 init = mkexpr (OPASSIGN, cpexpr((expptr)dovarp), doinit);
527 inc = mkexpr (OPPLUSEQ, (expptr)dovarp, cpexpr (ctlstack -> dostep));
529 if (!onetripflag && ISCONST (ctlstack -> domax) && ISCONST (doinit)
530 && ctlstack -> dostepsign != VARSTEP) {
533 tester = mkexpr (OPMINUS, cpexpr (doinit),
534 cpexpr (ctlstack -> domax));
535 if (incsign == conssgn (tester))
536 warn ("DO range never executed");
538 } /* if !onetripflag && */
540 p1_for (init, test, inc);
550 if( ctlstack < ctls )
551 Fatal("control stack empty");
552 here = ctlstack->dolabel;
553 if (ctlstack->ctltype != CTLDO || here >= 0) {
554 err("misplaced ENDDO");
557 if (np != ctlstack->loopname) {
558 if (np1 = ctlstack->loopname)
559 errstr("expected \"enddo %s\"", np1->fvarname);
561 err("expected unnamed ENDDO");
562 for(cf = ctls; cf < ctlstack; cf++)
563 if (cf->ctltype == CTLDO && cf->loopname == np) {
575 register struct Ctlframe *q;
576 Namep np; /* name of the current DO index */
581 /* Many DO's can end at the same statement, so keep looping over all
584 while(here == dorange)
586 if(np = ctlstack->donamep)
590 /* Now we're done with all of the tests, and the loop has terminated.
591 Store the index value back in long-term memory */
593 if(ap = memversion(np))
594 puteq((expptr)ap, (expptr)mkplace(np));
595 for(i = 0 ; i < 4 ; ++i)
596 ctlstack->ctlabels[i] = 0;
597 deregister(ctlstack->donamep);
598 ctlstack->donamep->vdovar = NO;
599 e = ctlstack->dostep;
600 if (e->tag == TADDR && e->addrblock.istemp)
605 if (e->tag == TADDR && e->addrblock.istemp)
610 else if (ctlstack->dowhile)
613 /* Set dorange to the closing label of the next most enclosing DO loop
619 for(q = ctlstack ; q>=ctls ; --q)
620 if(q->ctltype == CTLDO)
622 dorange = q->dolabel;
628 exassign(vname, labelval)
629 register Namep vname;
630 struct Labelblock *labelval;
635 static char nullstr[] = "";
637 register chainp cp, cpprev;
638 register ftnint k, stno;
641 if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) {
642 err("noninteger assign variable");
646 /* If the label hasn't been defined, then we do things twice:
647 * once for an executable stmt label, once for a format
650 /* code for executable label... */
652 /* Now store the assigned value in a list associated with this variable.
653 This will be used later to generate a switch() statement in the C output */
655 if (!labelval->labdefined || !labelval->fmtstring) {
657 if (vname -> vis_assigned == 0) {
658 vname -> varxptr.assigned_values = CHNULL;
659 vname -> vis_assigned = 1;
662 /* don't duplicate labels... */
664 stno = labelval->stateno;
666 for(k = 0, cp = vname->varxptr.assigned_values;
667 cp; cpprev = cp, cp = cp->nextp, k++)
668 if ((ftnint)cp->datap == stno)
671 cp = mkchain((char *)stno, CHNULL);
675 vname->varxptr.assigned_values = cp;
676 labelval->labused = 1;
678 putout(mkexpr(OPASSIGN, (expptr)p, mkintcon(k)));
681 /* Code for FORMAT label... */
683 fs = labelval->fmtstring;
684 if (!labelval->labdefined || fs && fs != nullstr) {
685 extern void fmtname();
688 labelval->fmtstring = nullstr;
689 labelval->fmtlabused = 1;
690 p = ALLOC(Addrblock);
694 p->memoffset = ICON(0);
696 q = ALLOC(Addrblock);
701 q->memoffset = ICON(0);
702 q->uname_tag = UNAM_IDENT;
703 sprintf(q->user.ident, "fmt_%ld", labelval->stateno);
704 putout(mkexpr(OPASSIGN, (expptr)p, (expptr)q));
711 exarif(expr, neglab, zerlab, poslab)
713 struct Labelblock *neglab, *zerlab, *poslab;
715 register int lm, lz, lp;
717 lm = neglab->stateno;
718 lz = zerlab->stateno;
719 lp = poslab->stateno;
720 expr = fixtype(expr);
722 if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) )
724 err("invalid type of arithmetic if expression");
729 if (lm == lz && lz == lp)
732 exar2(OPLE, expr, neglab, poslab);
734 exar2(OPNE, expr, neglab, zerlab);
736 exar2(OPGE, expr, zerlab, neglab);
740 if (!addressable (expr)) {
741 t = (expptr) Mktemp(expr -> headblock.vtype, ENULL);
742 expr = mkexpr (OPASSIGN, cpexpr (t), expr);
744 t = (expptr) cpexpr (expr);
746 p1_if(putx(fixtype(mkexpr (OPLT, expr, ICON (0)))));
748 p1_elif (mkexpr (OPEQ, t, ICON (0)));
759 /* exar2 -- Do arithmetic IF for only 2 distinct labels; if !(e.op.0)
760 goto l2 else goto l1. If this seems backwards, that's because it is,
761 in order to make the 1 pass algorithm work. */
767 struct Labelblock *l1, *l2;
771 comp = mkexpr (op, e, ICON (0));
772 p1_if(putx(fixtype(comp)));
780 /* exreturn -- return the value in p from a SUBROUTINE call -- used to
781 implement the alternate return mechanism */
786 if(procclass != CLPROC)
787 warn("RETURN statement in main or block data");
788 if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
790 err("alternate return in nonsubroutine");
794 if (p || proctype == TYSUBR) {
795 if (p == ENULL) p = ICON (0);
796 p = mkconv (TYLONG, fixtype (p));
798 } /* if p || proctype == TYSUBR */
800 p1_subr_ret((expptr)retslot);
811 if( ! ISINT(p->vtype) )
812 err("assigned goto variable must be integer");