00668 {
00669         register struct Ctlframe *q;
00670         Namep np;                       /* name of the current DO index */
00671         Addrp ap;
00672         register int i;
00673         register expptr e;
00674 
00675 /* Many DO's can end at the same statement, so keep looping over all
00676    nested indicies */
00677 
00678         while(here == dorange)
00679         {
00680                 if(np = ctlstack->donamep)
00681                         {
00682                         p1for_end ();
00683 
00684 /* Now we're done with all of the tests, and the loop has terminated.
00685    Store the index value back in long-term memory */
00686 
00687                         if(ap = memversion(np))
00688                                 puteq((expptr)ap, (expptr)mkplace(np));
00689                         for(i = 0 ; i < 4 ; ++i)
00690                                 ctlstack->ctlabels[i] = 0;
00691                         deregister(ctlstack->donamep);
00692                         ctlstack->donamep->vdovar = NO;
00693                         /* ctlstack->dostep and ctlstack->domax can be zero */
00694                         /* with sufficiently bizarre (erroneous) syntax */
00695                         if (e = ctlstack->dostep)
00696                                 if (e->tag == TADDR && e->addrblock.istemp)
00697                                         frtemp((Addrp)e);
00698                                 else
00699                                         frexpr(e);
00700                         if (e = ctlstack->domax)
00701                                 if (e->tag == TADDR && e->addrblock.istemp)
00702                                         frtemp((Addrp)e);
00703                                 else
00704                                         frexpr(e);
00705                         if (e = ctlstack->doinit)
00706                                 frtemp((Addrp)e);
00707                         }
00708                 else if (ctlstack->dowhile)
00709                         p1for_end ();
00710 
00711 /* Set   dorange   to the closing label of the next most enclosing DO loop
00712    */
00713 
00714                 popctl();
00715                 poplab();
00716                 dorange = 0;
00717                 for(q = ctlstack ; q>=ctls ; --q)
00718                         if(q->ctltype == CTLDO)
00719                         {
00720                                 dorange = q->dolabel;
00721                                 break;
00722                         }
00723         }
00724 }

00877 {
00878         expptr comp;
00879 
00880         comp = mkexpr (op, e, ICON (0));
00881         p1_if(putx(fixtype(comp)));
00882         exgoto(l1);
00883         p1_else ();
00884         exgoto(l2);
00885         p1else_end ();
00886 }

00818 {
00819     register int lm, lz, lp;
00820 
00821     lm = neglab->stateno;
00822     lz = zerlab->stateno;
00823     lp = poslab->stateno;
00824     expr = fixtype(expr);
00825 
00826     if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) )
00827     {
00828         err("invalid type of arithmetic if expression");
00829         frexpr(expr);
00830     }
00831     else
00832     {
00833         if (lm == lz && lz == lp)
00834             exgoto (neglab);
00835         else if(lm == lz)
00836             exar2(OPLE, expr, neglab, poslab);
00837         else if(lm == lp)
00838             exar2(OPNE, expr, neglab, zerlab);
00839         else if(lz == lp)
00840             exar2(OPGE, expr, zerlab, neglab);
00841         else {
00842             expptr t;
00843 
00844             if (!addressable (expr)) {
00845                 t = (expptr) mktmp(expr -> headblock.vtype, ENULL);
00846                 expr = mkexpr (OPASSIGN, cpexpr (t), expr);
00847             } else
00848                 t = (expptr) cpexpr (expr);
00849 
00850             p1_if(putx(fixtype(mkexpr (OPLT, expr, ICON (0)))));
00851             exgoto(neglab);
00852             p1_elif (mkexpr (OPEQ, t, ICON (0)));
00853             exgoto(zerlab);
00854             p1_else ();
00855             exgoto(poslab);
00856             p1else_end ();
00857         } /* else */
00858     }
00859 }

00925 {
00926         register Addrp p;
00927 
00928         p = mkplace(labvar);
00929         if( ! ISINT(p->vtype) )
00930                 err("assigned goto variable must be integer");
00931         else {
00932                 p1_asgoto (p);
00933         } /* else */
00934 }

00734 {
00735         Addrp p;
00736         register Addrp q;
00737         char *fs;
00738         register chainp cp, cpprev;
00739         register ftnint k, stno;
00740 
00741         p = mkplace(vname);
00742         if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) {
00743                 err("noninteger assign variable");
00744                 return;
00745                 }
00746 
00747         /* If the label hasn't been defined, then we do things twice:
00748          * once for an executable stmt label, once for a format
00749          */
00750 
00751         /* code for executable label... */
00752 
00753 /* Now store the assigned value in a list associated with this variable.
00754    This will be used later to generate a switch() statement in the C output */
00755 
00756         fs = labelval->fmtstring;
00757         if (!labelval->labdefined || !fs) {
00758 
00759                 if (vname -> vis_assigned == 0) {
00760                         vname -> varxptr.assigned_values = CHNULL;
00761                         vname -> vis_assigned = 1;
00762                         }
00763 
00764                 /* don't duplicate labels... */
00765 
00766                 stno = labelval->stateno;
00767                 cpprev = 0;
00768                 for(k = 0, cp = vname->varxptr.assigned_values;
00769                                 cp; cpprev = cp, cp = cp->nextp, k++)
00770                         if ((ftnint)cp->datap == stno)
00771                                 break;
00772                 if (!cp) {
00773                         cp = mkchain((char *)stno, CHNULL);
00774                         if (cpprev)
00775                                 cpprev->nextp = cp;
00776                         else
00777                                 vname->varxptr.assigned_values = cp;
00778                         labelval->labused = 1;
00779                         }
00780                 putout(mkexpr(OPASSIGN, (expptr)p, mkintcon(k)));
00781                 }
00782 
00783         /* Code for FORMAT label... */
00784 
00785         if (!labelval->labdefined || fs) {
00786 
00787                 labelval->fmtlabused = 1;
00788                 p = ALLOC(Addrblock);
00789                 p->tag = TADDR;
00790                 p->vtype = TYCHAR;
00791                 p->vstg = STGAUTO;
00792                 p->memoffset = ICON(0);
00793                 fmtname(vname, p);
00794                 q = ALLOC(Addrblock);
00795                 q->tag = TADDR;
00796                 q->vtype = TYCHAR;
00797                 q->vstg = STGAUTO;
00798                 q->ntempelt = 1;
00799                 q->memoffset = ICON(0);
00800                 q->uname_tag = UNAM_IDENT;
00801                 sprintf(q->user.ident, "fmt_%ld", labelval->stateno);
00802                 putout(mkexpr(OPASSIGN, (expptr)p, (expptr)q));
00803                 }
00804 
00805 } /* exassign */

00314 {
00315         register expptr p;
00316 
00317         if (name->vtype != TYSUBR) {
00318                 if (name->vinfproc && !name->vcalled) {
00319                         name->vtype = TYSUBR;
00320                         frexpr(name->vleng);
00321                         name->vleng = 0;
00322                         }
00323                 else if (!name->vimpltype && name->vtype != TYUNKNOWN)
00324                         mixed_type(name);
00325                 else
00326                         settype(name, TYSUBR, (ftnint)0);
00327                 }
00328         p = mkfunct( mkprim(name, args, CHNULL) );
00329         if (p->tag == TERROR)
00330                 return;
00331 
00332 /* Subroutines and their identifiers acquire the type INT */
00333 
00334         p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
00335 
00336 /* Handle the alternate return mechanism */
00337 
00338         if(nstars > 0)
00339                 putcmgo(putx(fixtype(p)), nstars, labels);
00340         else
00341                 putexpr(p);
00342 }

00424 {
00425         register expptr p;
00426         register Namep np;
00427         chainp cp;              /* loops over the fields in   spec */
00428         register int i;
00429         int dotype;             /* type of the index variable */
00430         int incsign;            /* sign of the increment, if it's constant
00431                                    */
00432         Addrp dovarp;           /* loop index variable */
00433         expptr doinit;          /* constant or register for init param */
00434         expptr par[3];          /* local specification parameters */
00435 
00436         expptr init, test, inc; /* Expressions in the resulting FOR loop */
00437 
00438 
00439         test = ENULL;
00440 
00441         pushctl(CTLDO);
00442         dorange = ctlstack->dolabel = range;
00443         ctlstack->loopname = loopname;
00444 
00445 /* Declare the loop index */
00446 
00447         np = (Namep)spec->datap;
00448         ctlstack->donamep = NULL;
00449         if (!np) { /* do while */
00450                 ctlstack->dowhile = 1;
00451 #if 0
00452                 if (loopname) {
00453                         if (loopname->vtype == TYUNKNOWN) {
00454                                 loopname->vdcldone = 1;
00455                                 loopname->vclass = CLLABEL;
00456                                 loopname->vprocclass = PLABEL;
00457                                 loopname->vtype = TYLABEL;
00458                                 }
00459                         if (loopname->vtype == TYLABEL)
00460                                 if (loopname->vdovar)
00461                                         dclerr("already in use as a loop name",
00462                                                 loopname);
00463                                 else
00464                                         loopname->vdovar = 1;
00465                         else
00466                                 dclerr("already declared; cannot be a loop name",
00467                                         loopname);
00468                         }
00469 #endif
00470                 putwhile((expptr)spec->nextp);
00471                 NOEXT("do while");
00472                 spec->nextp = 0;
00473                 frchain(&spec);
00474                 return;
00475                 }
00476         if(np->vdovar)
00477         {
00478                 errstr("nested loops with variable %s", np->fvarname);
00479                 ctlstack->donamep = NULL;
00480                 return;
00481         }
00482 
00483 /* Create a memory-resident version of the index variable */
00484 
00485         dovarp = mkplace(np);
00486         if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) )
00487         {
00488                 err("bad type on do variable");
00489                 return;
00490         }
00491         ctlstack->donamep = np;
00492 
00493         np->vdovar = YES;
00494 
00495 /* Now   dovarp   points to the index to be used within the loop,   dostgp
00496    points to the one which may need to be stored */
00497 
00498         dotype = dovarp->vtype;
00499 
00500 /* Count the input specifications and type-check each one independently;
00501    this just eliminates non-numeric values from the specification */
00502 
00503         for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
00504         {
00505                 p = par[i++] = fixtype((tagptr)cp->datap);
00506                 if( ! ONEOF(p->headblock.vtype, MSKINT|MSKREAL) )
00507                 {
00508                         err("bad type on DO parameter");
00509                         return;
00510                 }
00511         }
00512 
00513         frchain(&spec);
00514         switch(i)
00515         {
00516         case 0:
00517         case 1:
00518                 err("too few DO parameters");
00519                 return;
00520 
00521         default:
00522                 err("too many DO parameters");
00523                 return;
00524 
00525         case 2:
00526                 DOINCR = (expptr) ICON(1);
00527 
00528         case 3:
00529                 break;
00530         }
00531 
00532 
00533 /* Now all of the local specification fields are set, but their types are
00534    not yet consistent */
00535 
00536 /* Declare the loop initialization value, casting it properly and declaring a
00537    register if need be */
00538 
00539         ctlstack->doinit = 0;
00540         if (ISCONST (DOINIT) || !onetripflag)
00541 /* putx added 6-29-89 (mwm), not sure if fixtype is required, but I doubt it
00542    since mkconv is called just before */
00543                 doinit = putx (mkconv (dotype, DOINIT));
00544         else  {
00545             if (onetripflag)
00546                 ctlstack->doinit = doinit = (expptr) mktmp0(dotype, ENULL);
00547             else
00548                 doinit = (expptr) mktmp(dotype, ENULL);
00549             puteq (cpexpr (doinit), DOINIT);
00550         } /* else */
00551 
00552 /* Declare the loop ending value, casting it to the type of the index
00553    variable */
00554 
00555         if( ISCONST(DOLIMIT) )
00556                 ctlstack->domax = mkconv(dotype, DOLIMIT);
00557         else {
00558                 ctlstack->domax = (expptr) mktmp0(dotype, ENULL);
00559                 puteq (cpexpr (ctlstack -> domax), DOLIMIT);
00560         } /* else */
00561 
00562 /* Declare the loop increment value, casting it to the type of the index
00563    variable */
00564 
00565         if( ISCONST(DOINCR) )
00566         {
00567                 ctlstack->dostep = mkconv(dotype, DOINCR);
00568                 if( (incsign = conssgn(ctlstack->dostep)) == 0)
00569                         err("zero DO increment");
00570                 ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
00571         }
00572         else
00573         {
00574                 ctlstack->dostep = (expptr) mktmp0(dotype, ENULL);
00575                 ctlstack->dostepsign = VARSTEP;
00576                 puteq (cpexpr (ctlstack -> dostep), DOINCR);
00577         }
00578 
00579 /* All data is now properly typed and in the   ctlstack,   except for the
00580    initial value.  Assignments of temps have been generated already */
00581 
00582         switch (ctlstack -> dostepsign) {
00583             case VARSTEP:
00584                 test = mkexpr (OPQUEST, mkexpr (OPLT,
00585                         cpexpr (ctlstack -> dostep), ICON(0)),
00586                         mkexpr (OPCOLON,
00587                             mkexpr (OPGE, cpexpr((expptr)dovarp),
00588                                     cpexpr (ctlstack -> domax)),
00589                             mkexpr (OPLE, cpexpr((expptr)dovarp),
00590                                     cpexpr (ctlstack -> domax))));
00591                 break;
00592             case POSSTEP:
00593                 test = mkexpr (OPLE, cpexpr((expptr)dovarp),
00594                         cpexpr (ctlstack -> domax));
00595                 break;
00596             case NEGSTEP:
00597                 test = mkexpr (OPGE, cpexpr((expptr)dovarp),
00598                         cpexpr (ctlstack -> domax));
00599                 break;
00600             default:
00601                 erri ("exdo:  bad dostepsign '%d'", ctlstack -> dostepsign);
00602                 break;
00603         } /* switch (ctlstack -> dostepsign) */
00604 
00605         if (onetripflag)
00606             test = mkexpr (OPOR, test,
00607                     mkexpr (OPEQ, cpexpr((expptr)dovarp), cpexpr (doinit)));
00608         init = mkexpr (OPASSIGN, cpexpr((expptr)dovarp),
00609                         ctlstack->doinit ? cpexpr(doinit) : doinit);
00610         inc = mkexpr (OPPLUSEQ, (expptr)dovarp, cpexpr (ctlstack -> dostep));
00611 
00612         if (!onetripflag && ISCONST (ctlstack -> domax) && ISCONST (doinit)
00613                 && ctlstack -> dostepsign != VARSTEP) {
00614             expptr tester;
00615 
00616             tester = mkexpr (OPMINUS, cpexpr (doinit),
00617                     cpexpr (ctlstack -> domax));
00618             if (incsign == conssgn (tester))
00619                 warn ("DO range never executed");
00620             frexpr (tester);
00621         } /* if !onetripflag && */
00622 
00623         p1_for (init, test, inc);
00624 }

00055 {
00056     if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
00057         putif(p, 1);    /* 1 ==> elseif */
00058     else
00059         execerr("elseif out of place", CNULL);
00060 }

00067 {
00068         register struct Ctlframe *c;
00069 
00070         for(c = ctlstack; c->ctltype == CTLIFX; --c);
00071         if(c->ctltype == CTLIF) {
00072                 p1_else ();
00073                 c->ctltype = CTLELSE;
00074                 }
00075         else
00076                 execerr("else out of place", CNULL);
00077         }

00633 {
00634         Namep np1;
00635         int here;
00636         struct Ctlframe *cf;
00637 
00638         if( ctlstack < ctls )
00639                 goto misplaced;
00640         here = ctlstack->dolabel;
00641         if (ctlstack->ctltype != CTLDO
00642         || here >= 0 && (!thislabel || thislabel->labelno != here)) {
00643  misplaced:
00644                 err("misplaced ENDDO");
00645                 return;
00646                 }
00647         if (np != ctlstack->loopname) {
00648                 if (np1 = ctlstack->loopname)
00649                         errstr("expected \"enddo %s\"", np1->fvarname);
00650                 else
00651                         err("expected unnamed ENDDO");
00652                 for(cf = ctls; cf < ctlstack; cf++)
00653                         if (cf->ctltype == CTLDO && cf->loopname == np) {
00654                                 here = cf->dolabel;
00655                                 break;
00656                                 }
00657                 }
00658         enddo(here);
00659         }

00085 {
00086         while(ctlstack->ctltype == CTLIFX) {
00087                 popctl();
00088                 p1else_end();
00089                 }
00090         if(ctlstack->ctltype == CTLIF) {
00091                 popctl();
00092                 p1_endif ();
00093                 }
00094         else if(ctlstack->ctltype == CTLELSE) {
00095                 popctl();
00096                 p1else_end ();
00097                 }
00098         else
00099                 execerr("endif out of place", CNULL);
00100         }

00199 {
00200         if(lp->tag != TPRIM)
00201         {
00202                 err("assignment to a non-variable");
00203                 frexpr((expptr)lp);
00204                 frexpr(rp);
00205         }
00206         else if(lp->namep->vclass!=CLVAR && lp->argsp)
00207         {
00208                 if(parstate >= INEXEC)
00209                         errstr("statement function %.62s amid executables.",
00210                                 lp->namep->fvarname);
00211                 mkstfunct(lp, rp);
00212         }
00213         else if (lp->vtype == TYSUBR)
00214                 err("illegal use of subroutine name");
00215         else
00216         {
00217                 expptr new_lp, new_rp;
00218 
00219                 if(parstate < INDATA)
00220                         enddcl();
00221                 new_lp = mklhs (lp, keepsubs);
00222                 new_rp = fixtype (rp);
00223                 puteq(new_lp, new_rp);
00224         }
00225 }

00181 {
00182         lab->labused = 1;
00183         p1_goto (lab -> stateno);
00184 }

00042 {
00043     pushctl(CTLIF);
00044     putif(p, 0);        /* 0 => if, not elseif */
00045 }

00899 {
00900         if(procclass != CLPROC)
00901                 warn("RETURN statement in main or block data");
00902         if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
00903         {
00904                 err("alternate return in nonsubroutine");
00905                 p = 0;
00906         }
00907 
00908         if (p || proctype == TYSUBR) {
00909                 if (p == ENULL) p = ICON (0);
00910                 p = mkconv (TYLONG, fixtype (p));
00911                 p1_subr_ret (p);
00912         } /* if p || proctype == TYSUBR */
00913         else
00914             p1_subr_ret((expptr)retslot);
00915 }

00353 {
00354         char *str;
00355         int n;
00356 
00357         if(p)
00358         {
00359                 if( ! ISCONST(p) )
00360                 {
00361                         execerr("pause/stop argument must be constant", CNULL);
00362                         frexpr(p);
00363                         p = mkstrcon(0, CNULL);
00364                 }
00365                 else if( ISINT(p->constblock.vtype) )
00366                 {
00367                         str = convic(p->constblock.Const.ci);
00368                         n = strlen(str);
00369                         if(n > 0)
00370                         {
00371                                 p->constblock.Const.ccp = copyn(n, str);
00372                                 p->constblock.Const.ccp1.blanks = 0;
00373                                 p->constblock.vtype = TYCHAR;
00374                                 p->constblock.vleng = (expptr) ICON(n);
00375                         }
00376                         else
00377                                 p = (expptr) mkstrcon(0, CNULL);
00378                 }
00379                 else if(p->constblock.vtype != TYCHAR)
00380                 {
00381                         execerr("pause/stop argument must be integer or string", CNULL);
00382                         p = (expptr) mkstrcon(0, CNULL);
00383                 }
00384         }
00385         else    p = (expptr) mkstrcon(0, CNULL);
00386 
00387     {
00388         expptr subr_call;
00389 
00390         subr_call = call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p);
00391         putexpr( subr_call );
00392     }
00393 }

00297 {
00298         char buf[128];
00299         sprintf(buf, "%s function %.90s invoked as subroutine",
00300                 ftn_types[np->vtype], np->fvarname);
00301         warn(buf);
00302         }

00242 {
00243         register struct Primblock *p;
00244         register Namep np;
00245         chainp args;
00246 
00247         laststfcn = thisstno;
00248         np = lp->namep;
00249         if(np->vclass == CLUNKNOWN)
00250                 np->vclass = CLPROC;
00251         else
00252         {
00253                 dclerr("redeclaration of statement function", np);
00254                 return;
00255         }
00256         np->vprocclass = PSTFUNCT;
00257         np->vstg = STGSTFUNCT;
00258 
00259 /* Set the type of the function */
00260 
00261         impldcl(np);
00262         if (np->vtype == TYCHAR && !np->vleng)
00263                 err("character statement function with length (*)");
00264         args = (lp->argsp ? lp->argsp->listp : CHNULL);
00265         np->varxptr.vstfdesc = mkchain((char *)args, (chainp)rp);
00266 
00267         for(doing_stmtfcn = 1 ; args ; args = args->nextp)
00268 
00269 /* It is an error for the formal parameters to have arguments or
00270    subscripts */
00271 
00272                 if( ((tagptr)(args->datap))->tag!=TPRIM ||
00273                     (p = (struct Primblock *)(args->datap) )->argsp ||
00274                     p->fcharp || p->lcharp ) {
00275                         err("non-variable argument in statement function definition");
00276                         args->datap = 0;
00277                         }
00278                 else
00279                 {
00280 
00281 /* Replace the name on the left-hand side */
00282 
00283                         args->datap = (char *)p->namep;
00284                         vardcl(p -> namep);
00285                         free((char *)p);
00286                 }
00287         doing_stmtfcn = 0;
00288 }

00109 {
00110         if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
00111                 pushctl(CTLIFX);
00112         else
00113                 err("new_endif bug");
00114         }

00142 {
00143         if( ctlstack-- < ctls )
00144                 Fatal("control stack empty");
00145         --blklevel;
00146 }

00154 {
00155         register struct Labelblock  *lp;
00156 
00157         for(lp = labeltab ; lp < highlabtab ; ++lp)
00158                 if(lp->labdefined)
00159                 {
00160                         /* mark all labels in inner blocks unreachable */
00161                         if(lp->blklevel > blklevel)
00162                                 lp->labinacc = YES;
00163                 }
00164                 else if(lp->blklevel > blklevel)
00165                 {
00166                         /* move all labels referred to in inner blocks out a level */
00167                         lp->blklevel = blklevel;
00168                 }
00169 }

00126 {
00127         register int i;
00128 
00129         if(++ctlstack >= lastctl)
00130                 many("loops or if-then-elses", 'c', maxctl);
00131         ctlstack->ctltype = code;
00132         for(i = 0 ; i < 4 ; ++i)
00133                 ctlstack->ctlabels[i] = 0;
00134         ctlstack->dowhile = 0;
00135         ctlstack->domax = ctlstack->dostep = 0; /* in case of errors */
00136         ++blklevel;
00137 }