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