00001 /****************************************************************
00002 Copyright 1990, 1993 - 1996 by AT&T, Lucent Technologies and Bellcore.
00003 
00004 Permission to use, copy, modify, and distribute this software
00005 and its documentation for any purpose and without fee is hereby
00006 granted, provided that the above copyright notice appear in all
00007 copies and that both that the copyright notice and this
00008 permission notice and warranty disclaimer appear in supporting
00009 documentation, and that the names of AT&T, Bell Laboratories,
00010 Lucent or Bellcore or any of their entities not be used in
00011 advertising or publicity pertaining to distribution of the
00012 software without specific, written prior permission.
00013 
00014 AT&T, Lucent and Bellcore disclaim all warranties with regard to
00015 this software, including all implied warranties of
00016 merchantability and fitness.  In no event shall AT&T, Lucent or
00017 Bellcore be liable for any special, indirect or consequential
00018 damages or any damages whatsoever resulting from loss of use,
00019 data or profits, whether in an action of contract, negligence or
00020 other tortious action, arising out of or in connection with the
00021 use or performance of this software.
00022 ****************************************************************/
00023 
00024 #include "defs.h"
00025 #include "p1defs.h"
00026 #include "names.h"
00027 
00028 static void exar2 Argdcl((int, tagptr, struct Labelblock*, struct Labelblock*));
00029 static void popctl Argdcl((void));
00030 static void pushctl Argdcl((int));
00031 
00032 /*   Logical IF codes
00033 */
00034 
00035  void
00036 #ifdef KR_headers
00037 exif(p)
00038         expptr p;
00039 #else
00040 exif(expptr p)
00041 #endif
00042 {
00043     pushctl(CTLIF);
00044     putif(p, 0);        /* 0 => if, not elseif */
00045 }
00046 
00047 
00048  void
00049 #ifdef KR_headers
00050 exelif(p)
00051         expptr p;
00052 #else
00053 exelif(expptr p)
00054 #endif
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 }
00061 
00062 
00063 
00064 
00065  void
00066 exelse(Void)
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         }
00078 
00079  void
00080 #ifdef KR_headers
00081 exendif()
00082 #else
00083 exendif()
00084 #endif
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         }
00101 
00102 
00103  void
00104 #ifdef KR_headers
00105 new_endif()
00106 #else
00107 new_endif()
00108 #endif
00109 {
00110         if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
00111                 pushctl(CTLIFX);
00112         else
00113                 err("new_endif bug");
00114         }
00115 
00116 /* pushctl -- Start a new control construct, initialize the labels (to
00117    zero) */
00118 
00119  LOCAL void
00120 #ifdef KR_headers
00121 pushctl(code)
00122         int code;
00123 #else
00124 pushctl(int code)
00125 #endif
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 }
00138 
00139 
00140  LOCAL void
00141 popctl(Void)
00142 {
00143         if( ctlstack-- < ctls )
00144                 Fatal("control stack empty");
00145         --blklevel;
00146 }
00147 
00148 
00149 
00150 /* poplab -- update the flags in   labeltab   */
00151 
00152  LOCAL void
00153 poplab(Void)
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 }
00170 
00171 
00172 /*  BRANCHING CODE
00173 */
00174  void
00175 #ifdef KR_headers
00176 exgoto(lab)
00177         struct Labelblock *lab;
00178 #else
00179 exgoto(struct Labelblock *lab)
00180 #endif
00181 {
00182         lab->labused = 1;
00183         p1_goto (lab -> stateno);
00184 }
00185 
00186 
00187 
00188 
00189 
00190 
00191  void
00192 #ifdef KR_headers
00193 exequals(lp, rp)
00194         register struct Primblock *lp;
00195         register expptr rp;
00196 #else
00197 exequals(register struct Primblock *lp, register expptr rp)
00198 #endif
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 }
00226 
00227 
00228 
00229 /* Make Statement Function */
00230 
00231 long laststfcn = -1, thisstno;
00232 int doing_stmtfcn;
00233 
00234  void
00235 #ifdef KR_headers
00236 mkstfunct(lp, rp)
00237         struct Primblock *lp;
00238         expptr rp;
00239 #else
00240 mkstfunct(struct Primblock *lp, expptr rp)
00241 #endif
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 }
00289 
00290  static void
00291 #ifdef KR_headers
00292 mixed_type(np)
00293         Namep np;
00294 #else
00295 mixed_type(Namep np)
00296 #endif
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         }
00303 
00304  void
00305 #ifdef KR_headers
00306 excall(name, args, nstars, labels)
00307         Namep name;
00308         struct Listblock *args;
00309         int nstars;
00310         struct Labelblock **labels;
00311 #else
00312 excall(Namep name, struct Listblock *args, int nstars, struct Labelblock **labels)
00313 #endif
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 }
00343 
00344 
00345  void
00346 #ifdef KR_headers
00347 exstop(stop, p)
00348         int stop;
00349         register expptr p;
00350 #else
00351 exstop(int stop, register expptr p)
00352 #endif
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 }
00394 
00395 /* DO LOOP CODE */
00396 
00397 #define DOINIT  par[0]
00398 #define DOLIMIT par[1]
00399 #define DOINCR  par[2]
00400 
00401 
00402 /* Macros for   ctlstack -> dostepsign   */
00403 
00404 #define VARSTEP 0
00405 #define POSSTEP 1
00406 #define NEGSTEP 2
00407 
00408 
00409 /* exdo -- generate DO loop code.  In the case of a variable increment,
00410    positive increment tests are placed above the body, negative increment
00411    tests are placed below (see   enddo()   ) */
00412 
00413  void
00414 #ifdef KR_headers
00415 exdo(range, loopname, spec)
00416         int range;
00417         Namep loopname;
00418         chainp spec;
00419 #else
00420 exdo(int range, Namep loopname, chainp spec)
00421 #endif
00422                         /* range = end label */
00423                         /* input spec must have at least 2 exprs */
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 }
00625 
00626  void
00627 #ifdef KR_headers
00628 exenddo(np)
00629         Namep np;
00630 #else
00631 exenddo(Namep np)
00632 #endif
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         }
00660 
00661  void
00662 #ifdef KR_headers
00663 enddo(here)
00664         int here;
00665 #else
00666 enddo(int here)
00667 #endif
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 }
00725 
00726  void
00727 #ifdef KR_headers
00728 exassign(vname, labelval)
00729         register Namep vname;
00730         struct Labelblock *labelval;
00731 #else
00732 exassign(register Namep vname, struct Labelblock *labelval)
00733 #endif
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 */
00806 
00807 
00808  void
00809 #ifdef KR_headers
00810 exarif(expr, neglab, zerlab, poslab)
00811         expptr expr;
00812         struct Labelblock *neglab;
00813         struct Labelblock *zerlab;
00814         struct Labelblock *poslab;
00815 #else
00816 exarif(expptr expr, struct Labelblock *neglab, struct Labelblock *zerlab, struct Labelblock *poslab)
00817 #endif
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 }
00860 
00861 
00862 
00863 /* exar2 -- Do arithmetic IF for only 2 distinct labels;   if !(e.op.0)
00864    goto l2 else goto l1.  If this seems backwards, that's because it is,
00865    in order to make the 1 pass algorithm work. */
00866 
00867  LOCAL void
00868 #ifdef KR_headers
00869 exar2(op, e, l1, l2)
00870         int op;
00871         expptr e;
00872         struct Labelblock *l1;
00873         struct Labelblock *l2;
00874 #else
00875 exar2(int op, expptr e, struct Labelblock *l1, struct Labelblock *l2)
00876 #endif
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 }
00887 
00888 
00889 /* exreturn -- return the value in   p  from a SUBROUTINE call -- used to
00890    implement the alternate return mechanism */
00891 
00892  void
00893 #ifdef KR_headers
00894 exreturn(p)
00895         register expptr p;
00896 #else
00897 exreturn(register expptr p)
00898 #endif
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 }
00916 
00917 
00918  void
00919 #ifdef KR_headers
00920 exasgoto(labvar)
00921         Namep labvar;
00922 #else
00923 exasgoto(Namep labvar)
00924 #endif
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 }