sources/f2c/exec.c

   1 /****************************************************************
   2 Copyright 1990 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)
  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     if(ctlstack->ctltype==CTLIF) {
  59         p1_else ();
  60         ctlstack->ctltype = CTLELSE;
  61         }
  62     else
  63         execerr("else out of place", CNULL);
  64 }
  65
  66
  67 exendif()
  68 {
  69     if(ctlstack->ctltype == CTLIF) {
  70         popctl();
  71         p1_endif ();
  72     } else if(ctlstack->ctltype == CTLELSE) {
  73         popctl();
  74         p1else_end ();
  75     } else
  76         execerr("endif out of place", CNULL);
  77 }
  78
  79
  80
  81 /* pushctl -- Start a new control construct, initialize the labels (to
  82    zero) */
  83
  84  LOCAL void
  85 pushctl(code)
  86  int code;
  87 {
  88         register int i;
  89
  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;
  96         ++blklevel;
  97 }
  98
  99
 100  LOCAL void
 101 popctl()
 102 {
 103         if( ctlstack-- < ctls )
 104                 Fatal("control stack empty");
 105         --blklevel;
 106 }
 107
 108
 109
 110 /* poplab -- update the flags in   labeltab   */
 111
 112 LOCAL poplab()
 113 {
 114         register struct Labelblock  *lp;
 115
 116         for(lp = labeltab ; lp < highlabtab ; ++lp)
 117                 if(lp->labdefined)
 118                 {
 119                         /* mark all labels in inner blocks unreachable */
 120                         if(lp->blklevel > blklevel)
 121                                 lp->labinacc = YES;
 122                 }
 123                 else if(lp->blklevel > blklevel)
 124                 {
 125                         /* move all labels referred to in inner blocks out a level */
 126                         lp->blklevel = blklevel;
 127                 }
 128 }
 129
 130
 131 /*  BRANCHING CODE
 132 */
 133
 134 exgoto(lab)
 135 struct Labelblock *lab;
 136 {
 137         lab->labused = 1;
 138         p1_goto (lab -> stateno);
 139 }
 140
 141
 142
 143
 144
 145
 146
 147 exequals(lp, rp)
 148 register struct Primblock *lp;
 149 register expptr rp;
 150 {
 151         if(lp->tag != TPRIM)
 152         {
 153                 err("assignment to a non-variable");
 154                 frexpr((expptr)lp);
 155                 frexpr(rp);
 156         }
 157         else if(lp->namep->vclass!=CLVAR && lp->argsp)
 158         {
 159                 if(parstate >= INEXEC)
 160                         err("statement function amid executables");
 161                 mkstfunct(lp, rp);
 162         }
 163         else
 164         {
 165                 expptr new_lp, new_rp;
 166
 167                 if(parstate < INDATA)
 168                         enddcl();
 169                 new_lp = mklhs (lp);
 170                 new_rp = fixtype (rp);
 171                 puteq(new_lp, new_rp);
 172         }
 173 }
 174
 175
 176
 177 /* Make Statement Function */
 178
 179 long laststfcn = -1, thisstno;
 180 int doing_stmtfcn;
 181
 182 mkstfunct(lp, rp)
 183 struct Primblock *lp;
 184 expptr rp;
 185 {
 186         register struct Primblock *p;
 187         register Namep np;
 188         chainp args;
 189
 190         laststfcn = thisstno;
 191         np = lp->namep;
 192         if(np->vclass == CLUNKNOWN)
 193                 np->vclass = CLPROC;
 194         else
 195         {
 196                 dclerr("redeclaration of statement function", np);
 197                 return;
 198         }
 199         np->vprocclass = PSTFUNCT;
 200         np->vstg = STGSTFUNCT;
 201
 202 /* Set the type of the function */
 203
 204         impldcl(np);
 205         args = (lp->argsp ? lp->argsp->listp : CHNULL);
 206         np->varxptr.vstfdesc = mkchain((char *)args, (chainp)rp);
 207
 208         for(doing_stmtfcn = 1 ; args ; args = args->nextp)
 209
 210 /* It is an error for the formal parameters to have arguments or
 211    subscripts */
 212
 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");
 217                 else
 218                 {
 219
 220 /* Replace the name on the left-hand side */
 221
 222                         args->datap = (char *)p->namep;
 223                         vardcl(p -> namep);
 224                         free((char *)p);
 225                 }
 226         doing_stmtfcn = 0;
 227 }
 228
 229  static void
 230 mixed_type(np)
 231  Namep np;
 232 {
 233         char buf[128];
 234         sprintf(buf, "%s function %.90s invoked as subroutine",
 235                 ftn_types[np->vtype], np->fvarname);
 236         warn(buf);
 237         }
 238
 239
 240 excall(name, args, nstars, labels)
 241 Namep name;
 242 struct Listblock *args;
 243 int nstars;
 244 struct Labelblock *labels[ ];
 245 {
 246         register expptr p;
 247         extern void saveargtypes();
 248
 249         if (name->vtype != TYSUBR) {
 250                 if (name->vinfproc && !name->vcalled) {
 251                         name->vtype = TYSUBR;
 252                         frexpr(name->vleng);
 253                         name->vleng = 0;
 254                         }
 255                 else if (!name->vimpltype && name->vtype != TYUNKNOWN)
 256                         mixed_type(name);
 257                 else
 258                         settype(name, TYSUBR, (ftnint)0);
 259                 }
 260         p = mkfunct( mkprim(name, args, CHNULL) );
 261
 262 /* Subroutines and their identifiers acquire the type INT */
 263
 264         p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
 265
 266 /* Handle the alternate return mechanism */
 267
 268         if(nstars > 0) {
 269                 saveargtypes((Exprp)p);
 270                 putcmgo(p, nstars, labels);
 271         } else {
 272                 putexpr(p);
 273         } /* else */
 274 }
 275
 276
 277
 278 exstop(stop, p)
 279 int stop;
 280 register expptr p;
 281 {
 282         char *str;
 283         int n;
 284         expptr mkstrcon();
 285
 286         if(p)
 287         {
 288                 if( ! ISCONST(p) )
 289                 {
 290                         execerr("pause/stop argument must be constant", CNULL);
 291                         frexpr(p);
 292                         p = mkstrcon(0, CNULL);
 293                 }
 294                 else if( ISINT(p->constblock.vtype) )
 295                 {
 296                         str = convic(p->constblock.Const.ci);
 297                         n = strlen(str);
 298                         if(n > 0)
 299                         {
 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);
 304                         }
 305                         else
 306                                 p = (expptr) mkstrcon(0, CNULL);
 307                 }
 308                 else if(p->constblock.vtype != TYCHAR)
 309                 {
 310                         execerr("pause/stop argument must be integer or string", CNULL);
 311                         p = (expptr) mkstrcon(0, CNULL);
 312                 }
 313         }
 314         else    p = (expptr) mkstrcon(0, CNULL);
 315
 316     {
 317         expptr subr_call;
 318
 319         subr_call = call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p);
 320         putexpr( subr_call );
 321     }
 322 }
 323
 324 /* DO LOOP CODE */
 325
 326 #define DOINIT  par[0]
 327 #define DOLIMIT par[1]
 328 #define DOINCR  par[2]
 329
 330
 331 /* Macros for   ctlstack -> dostepsign   */
 332
 333 #define VARSTEP 0
 334 #define POSSTEP 1
 335 #define NEGSTEP 2
 336
 337
 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()   ) */
 341
 342 exdo(range, loopname, spec)
 343 int range;                      /* end label */
 344 Namep loopname;
 345 chainp spec;                    /* input spec must have at least 2 exprs */
 346 {
 347         register expptr p;
 348         register Namep np;
 349         chainp cp;              /* loops over the fields in   spec */
 350         register int i;
 351         int dotype;             /* type of the index variable */
 352         int incsign;            /* sign of the increment, if it's constant
 353                                    */
 354         Addrp dovarp;           /* loop index variable */
 355         expptr doinit;          /* constant or register for init param */
 356         expptr par[3];          /* local specification parameters */
 357
 358         expptr init, test, inc; /* Expressions in the resulting FOR loop */
 359
 360
 361         test = ENULL;
 362
 363         pushctl(CTLDO);
 364         dorange = ctlstack->dolabel = range;
 365         ctlstack->loopname = loopname;
 366
 367 /* Declare the loop index */
 368
 369         np = (Namep)spec->datap;
 370         ctlstack->donamep = NULL;
 371         if (!np) { /* do while */
 372                 ctlstack->dowhile = 1;
 373 #if 0
 374                 if (loopname) {
 375                         if (loopname->vtype == TYUNKNOWN) {
 376                                 loopname->vdcldone = 1;
 377                                 loopname->vclass = CLLABEL;
 378                                 loopname->vprocclass = PLABEL;
 379                                 loopname->vtype = TYLABEL;
 380                                 }
 381                         if (loopname->vtype == TYLABEL)
 382                                 if (loopname->vdovar)
 383                                         dclerr("already in use as a loop name",
 384                                                 loopname);
 385                                 else
 386                                         loopname->vdovar = 1;
 387                         else
 388                                 dclerr("already declared; cannot be a loop name",
 389                                         loopname);
 390                         }
 391 #endif
 392                 putwhile((expptr)spec->nextp);
 393                 NOEXT("do while");
 394                 spec->nextp = 0;
 395                 frchain(&spec);
 396                 return;
 397                 }
 398         if(np->vdovar)
 399         {
 400                 errstr("nested loops with variable %s", np->fvarname);
 401                 ctlstack->donamep = NULL;
 402                 return;
 403         }
 404
 405 /* Create a memory-resident version of the index variable */
 406
 407         dovarp = mkplace(np);
 408         if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) )
 409         {
 410                 err("bad type on do variable");
 411                 return;
 412         }
 413         ctlstack->donamep = np;
 414
 415         np->vdovar = YES;
 416
 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 */
 419
 420         dotype = dovarp->vtype;
 421
 422 /* Count the input specifications and type-check each one independently;
 423    this just eliminates non-numeric values from the specification */
 424
 425         for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
 426         {
 427                 p = par[i++] = fixtype((tagptr)cp->datap);
 428                 if( ! ONEOF(p->headblock.vtype, MSKINT|MSKREAL) )
 429                 {
 430                         err("bad type on DO parameter");
 431                         return;
 432                 }
 433         }
 434
 435         frchain(&spec);
 436         switch(i)
 437         {
 438         case 0:
 439         case 1:
 440                 err("too few DO parameters");
 441                 return;
 442
 443         default:
 444                 err("too many DO parameters");
 445                 return;
 446
 447         case 2:
 448                 DOINCR = (expptr) ICON(1);
 449
 450         case 3:
 451                 break;
 452         }
 453
 454
 455 /* Now all of the local specification fields are set, but their types are
 456    not yet consistent */
 457
 458 /* Declare the loop initialization value, casting it properly and declaring a
 459    register if need be */
 460
 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));
 465         else {
 466             doinit = (expptr) Mktemp(dotype, ENULL);
 467             puteq (cpexpr (doinit), DOINIT);
 468         } /* else */
 469
 470 /* Declare the loop ending value, casting it to the type of the index
 471    variable */
 472
 473         if( ISCONST(DOLIMIT) )
 474                 ctlstack->domax = mkconv(dotype, DOLIMIT);
 475         else {
 476                 ctlstack->domax = (expptr) mktmp0(dotype, ENULL);
 477                 puteq (cpexpr (ctlstack -> domax), DOLIMIT);
 478         } /* else */
 479
 480 /* Declare the loop increment value, casting it to the type of the index
 481    variable */
 482
 483         if( ISCONST(DOINCR) )
 484         {
 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);
 489         }
 490         else
 491         {
 492                 ctlstack->dostep = (expptr) mktmp0(dotype, ENULL);
 493                 ctlstack->dostepsign = VARSTEP;
 494                 puteq (cpexpr (ctlstack -> dostep), DOINCR);
 495         }
 496
 497 /* All data is now properly typed and in the   ctlstack,   except for the
 498    initial value.  Assignments of temps have been generated already */
 499
 500         switch (ctlstack -> dostepsign) {
 501             case VARSTEP:
 502                 test = mkexpr (OPQUEST, mkexpr (OPLT,
 503                         cpexpr (ctlstack -> dostep), ICON(0)),
 504                         mkexpr (OPCOLON,
 505                             mkexpr (OPGE, cpexpr((expptr)dovarp),
 506                                     cpexpr (ctlstack -> domax)),
 507                             mkexpr (OPLE, cpexpr((expptr)dovarp),
 508                                     cpexpr (ctlstack -> domax))));
 509                 break;
 510             case POSSTEP:
 511                 test = mkexpr (OPLE, cpexpr((expptr)dovarp),
 512                         cpexpr (ctlstack -> domax));
 513                 break;
 514             case NEGSTEP:
 515                 test = mkexpr (OPGE, cpexpr((expptr)dovarp),
 516                         cpexpr (ctlstack -> domax));
 517                 break;
 518             default:
 519                 erri ("exdo:  bad dostepsign '%d'", ctlstack -> dostepsign);
 520                 break;
 521         } /* switch (ctlstack -> dostepsign) */
 522
 523         if (onetripflag)
 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));
 528
 529         if (!onetripflag && ISCONST (ctlstack -> domax) && ISCONST (doinit)
 530                 && ctlstack -> dostepsign != VARSTEP) {
 531             expptr tester;
 532
 533             tester = mkexpr (OPMINUS, cpexpr (doinit),
 534                     cpexpr (ctlstack -> domax));
 535             if (incsign == conssgn (tester))
 536                 warn ("DO range never executed");
 537             frexpr (tester);
 538         } /* if !onetripflag && */
 539
 540         p1_for (init, test, inc);
 541 }
 542
 543 exenddo(np)
 544  Namep np;
 545 {
 546         Namep np1;
 547         int here;
 548         struct Ctlframe *cf;
 549
 550         if( ctlstack < ctls )
 551                 Fatal("control stack empty");
 552         here = ctlstack->dolabel;
 553         if (ctlstack->ctltype != CTLDO || here >= 0) {
 554                 err("misplaced ENDDO");
 555                 return;
 556                 }
 557         if (np != ctlstack->loopname) {
 558                 if (np1 = ctlstack->loopname)
 559                         errstr("expected \"enddo %s\"", np1->fvarname);
 560                 else
 561                         err("expected unnamed ENDDO");
 562                 for(cf = ctls; cf < ctlstack; cf++)
 563                         if (cf->ctltype == CTLDO && cf->loopname == np) {
 564                                 here = cf->dolabel;
 565                                 break;
 566                                 }
 567                 }
 568         enddo(here);
 569         }
 570
 571
 572 enddo(here)
 573 int here;
 574 {
 575         register struct Ctlframe *q;
 576         Namep np;                       /* name of the current DO index */
 577         Addrp ap;
 578         register int i;
 579         register expptr e;
 580
 581 /* Many DO's can end at the same statement, so keep looping over all
 582    nested indicies */
 583
 584         while(here == dorange)
 585         {
 586                 if(np = ctlstack->donamep)
 587                         {
 588                         p1for_end ();
 589
 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 */
 592
 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)
 601                                 frtemp((Addrp)e);
 602                         else
 603                                 frexpr(e);
 604                         e = ctlstack->domax;
 605                         if (e->tag == TADDR && e->addrblock.istemp)
 606                                 frtemp((Addrp)e);
 607                         else
 608                                 frexpr(e);
 609                         }
 610                 else if (ctlstack->dowhile)
 611                         p1for_end ();
 612
 613 /* Set   dorange   to the closing label of the next most enclosing DO loop
 614    */
 615
 616                 popctl();
 617                 poplab();
 618                 dorange = 0;
 619                 for(q = ctlstack ; q>=ctls ; --q)
 620                         if(q->ctltype == CTLDO)
 621                         {
 622                                 dorange = q->dolabel;
 623                                 break;
 624                         }
 625         }
 626 }
 627
 628 exassign(vname, labelval)
 629  register Namep vname;
 630 struct Labelblock *labelval;
 631 {
 632         Addrp p;
 633         expptr mkaddcon();
 634         register Addrp q;
 635         static char nullstr[] = "";
 636         char *fs;
 637         register chainp cp, cpprev;
 638         register ftnint k, stno;
 639
 640         p = mkplace(vname);
 641         if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) {
 642                 err("noninteger assign variable");
 643                 return;
 644                 }
 645
 646         /* If the label hasn't been defined, then we do things twice:
 647          * once for an executable stmt label, once for a format
 648          */
 649
 650         /* code for executable label... */
 651
 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 */
 654
 655         if (!labelval->labdefined || !labelval->fmtstring) {
 656
 657                 if (vname -> vis_assigned == 0) {
 658                         vname -> varxptr.assigned_values = CHNULL;
 659                         vname -> vis_assigned = 1;
 660                         }
 661
 662                 /* don't duplicate labels... */
 663
 664                 stno = labelval->stateno;
 665                 cpprev = 0;
 666                 for(k = 0, cp = vname->varxptr.assigned_values;
 667                                 cp; cpprev = cp, cp = cp->nextp, k++)
 668                         if ((ftnint)cp->datap == stno)
 669                                 break;
 670                 if (!cp) {
 671                         cp = mkchain((char *)stno, CHNULL);
 672                         if (cpprev)
 673                                 cpprev->nextp = cp;
 674                         else
 675                                 vname->varxptr.assigned_values = cp;
 676                         labelval->labused = 1;
 677                         }
 678                 putout(mkexpr(OPASSIGN, (expptr)p, mkintcon(k)));
 679                 }
 680
 681         /* Code for FORMAT label... */
 682
 683         fs = labelval->fmtstring;
 684         if (!labelval->labdefined || fs && fs != nullstr) {
 685                 extern void fmtname();
 686
 687                 if (!fs)
 688                         labelval->fmtstring = nullstr;
 689                 labelval->fmtlabused = 1;
 690                 p = ALLOC(Addrblock);
 691                 p->tag = TADDR;
 692                 p->vtype = TYCHAR;
 693                 p->vstg = STGAUTO;
 694                 p->memoffset = ICON(0);
 695                 fmtname(vname, p);
 696                 q = ALLOC(Addrblock);
 697                 q->tag = TADDR;
 698                 q->vtype = TYCHAR;
 699                 q->vstg = STGAUTO;
 700                 q->ntempelt = 1;
 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));
 705                 }
 706
 707 } /* exassign */
 708
 709
 710
 711 exarif(expr, neglab, zerlab, poslab)
 712 expptr expr;
 713 struct Labelblock *neglab, *zerlab, *poslab;
 714 {
 715     register int lm, lz, lp;
 716
 717     lm = neglab->stateno;
 718     lz = zerlab->stateno;
 719     lp = poslab->stateno;
 720     expr = fixtype(expr);
 721
 722     if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) )
 723     {
 724         err("invalid type of arithmetic if expression");
 725         frexpr(expr);
 726     }
 727     else
 728     {
 729         if (lm == lz && lz == lp)
 730             exgoto (neglab);
 731         else if(lm == lz)
 732             exar2(OPLE, expr, neglab, poslab);
 733         else if(lm == lp)
 734             exar2(OPNE, expr, neglab, zerlab);
 735         else if(lz == lp)
 736             exar2(OPGE, expr, zerlab, neglab);
 737         else {
 738             expptr t;
 739
 740             if (!addressable (expr)) {
 741                 t = (expptr) Mktemp(expr -> headblock.vtype, ENULL);
 742                 expr = mkexpr (OPASSIGN, cpexpr (t), expr);
 743             } else
 744                 t = (expptr) cpexpr (expr);
 745
 746             p1_if(putx(fixtype(mkexpr (OPLT, expr, ICON (0)))));
 747             exgoto(neglab);
 748             p1_elif (mkexpr (OPEQ, t, ICON (0)));
 749             exgoto(zerlab);
 750             p1_else ();
 751             exgoto(poslab);
 752             p1else_end ();
 753         } /* else */
 754     }
 755 }
 756
 757
 758
 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. */
 762
 763  LOCAL void
 764 exar2(op, e, l1, l2)
 765  int op;
 766  expptr e;
 767  struct Labelblock *l1, *l2;
 768 {
 769         expptr comp;
 770
 771         comp = mkexpr (op, e, ICON (0));
 772         p1_if(putx(fixtype(comp)));
 773         exgoto(l1);
 774         p1_else ();
 775         exgoto(l2);
 776         p1else_end ();
 777 }
 778
 779
 780 /* exreturn -- return the value in   p  from a SUBROUTINE call -- used to
 781    implement the alternate return mechanism */
 782
 783 exreturn(p)
 784 register expptr p;
 785 {
 786         if(procclass != CLPROC)
 787                 warn("RETURN statement in main or block data");
 788         if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
 789         {
 790                 err("alternate return in nonsubroutine");
 791                 p = 0;
 792         }
 793
 794         if (p || proctype == TYSUBR) {
 795                 if (p == ENULL) p = ICON (0);
 796                 p = mkconv (TYLONG, fixtype (p));
 797                 p1_subr_ret (p);
 798         } /* if p || proctype == TYSUBR */
 799         else
 800             p1_subr_ret((expptr)retslot);
 801 }
 802
 803
 804 exasgoto(labvar)
 805 Namep labvar;
 806 {
 807         register Addrp p;
 808         void p1_asgoto();
 809
 810         p = mkplace(labvar);
 811         if( ! ISINT(p->vtype) )
 812                 err("assigned goto variable must be integer");
 813         else {
 814                 p1_asgoto (p);
 815         } /* else */
 816 }