![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to exec.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / f2c|
Return to exec.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 ! root 1: /**************************************************************** ! 2: Copyright 1990, 1993 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, keepsubs); ! 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 ! 569: || here >= 0 && (!thislabel || thislabel->labelno != here)) { ! 570: err("misplaced ENDDO"); ! 571: return; ! 572: } ! 573: if (np != ctlstack->loopname) { ! 574: if (np1 = ctlstack->loopname) ! 575: errstr("expected \"enddo %s\"", np1->fvarname); ! 576: else ! 577: err("expected unnamed ENDDO"); ! 578: for(cf = ctls; cf < ctlstack; cf++) ! 579: if (cf->ctltype == CTLDO && cf->loopname == np) { ! 580: here = cf->dolabel; ! 581: break; ! 582: } ! 583: } ! 584: enddo(here); ! 585: } ! 586: ! 587: ! 588: enddo(here) ! 589: int here; ! 590: { ! 591: register struct Ctlframe *q; ! 592: Namep np; /* name of the current DO index */ ! 593: Addrp ap; ! 594: register int i; ! 595: register expptr e; ! 596: ! 597: /* Many DO's can end at the same statement, so keep looping over all ! 598: nested indicies */ ! 599: ! 600: while(here == dorange) ! 601: { ! 602: if(np = ctlstack->donamep) ! 603: { ! 604: p1for_end (); ! 605: ! 606: /* Now we're done with all of the tests, and the loop has terminated. ! 607: Store the index value back in long-term memory */ ! 608: ! 609: if(ap = memversion(np)) ! 610: puteq((expptr)ap, (expptr)mkplace(np)); ! 611: for(i = 0 ; i < 4 ; ++i) ! 612: ctlstack->ctlabels[i] = 0; ! 613: deregister(ctlstack->donamep); ! 614: ctlstack->donamep->vdovar = NO; ! 615: e = ctlstack->dostep; ! 616: if (e->tag == TADDR && e->addrblock.istemp) ! 617: frtemp((Addrp)e); ! 618: else ! 619: frexpr(e); ! 620: e = ctlstack->domax; ! 621: if (e->tag == TADDR && e->addrblock.istemp) ! 622: frtemp((Addrp)e); ! 623: else ! 624: frexpr(e); ! 625: } ! 626: else if (ctlstack->dowhile) ! 627: p1for_end (); ! 628: ! 629: /* Set dorange to the closing label of the next most enclosing DO loop ! 630: */ ! 631: ! 632: popctl(); ! 633: poplab(); ! 634: dorange = 0; ! 635: for(q = ctlstack ; q>=ctls ; --q) ! 636: if(q->ctltype == CTLDO) ! 637: { ! 638: dorange = q->dolabel; ! 639: break; ! 640: } ! 641: } ! 642: } ! 643: ! 644: exassign(vname, labelval) ! 645: register Namep vname; ! 646: struct Labelblock *labelval; ! 647: { ! 648: Addrp p; ! 649: expptr mkaddcon(); ! 650: register Addrp q; ! 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: fs = labelval->fmtstring; ! 671: if (!labelval->labdefined || !fs) { ! 672: ! 673: if (vname -> vis_assigned == 0) { ! 674: vname -> varxptr.assigned_values = CHNULL; ! 675: vname -> vis_assigned = 1; ! 676: } ! 677: ! 678: /* don't duplicate labels... */ ! 679: ! 680: stno = labelval->stateno; ! 681: cpprev = 0; ! 682: for(k = 0, cp = vname->varxptr.assigned_values; ! 683: cp; cpprev = cp, cp = cp->nextp, k++) ! 684: if ((ftnint)cp->datap == stno) ! 685: break; ! 686: if (!cp) { ! 687: cp = mkchain((char *)stno, CHNULL); ! 688: if (cpprev) ! 689: cpprev->nextp = cp; ! 690: else ! 691: vname->varxptr.assigned_values = cp; ! 692: labelval->labused = 1; ! 693: } ! 694: putout(mkexpr(OPASSIGN, (expptr)p, mkintcon(k))); ! 695: } ! 696: ! 697: /* Code for FORMAT label... */ ! 698: ! 699: if (!labelval->labdefined || fs) { ! 700: extern void fmtname(); ! 701: ! 702: labelval->fmtlabused = 1; ! 703: p = ALLOC(Addrblock); ! 704: p->tag = TADDR; ! 705: p->vtype = TYCHAR; ! 706: p->vstg = STGAUTO; ! 707: p->memoffset = ICON(0); ! 708: fmtname(vname, p); ! 709: q = ALLOC(Addrblock); ! 710: q->tag = TADDR; ! 711: q->vtype = TYCHAR; ! 712: q->vstg = STGAUTO; ! 713: q->ntempelt = 1; ! 714: q->memoffset = ICON(0); ! 715: q->uname_tag = UNAM_IDENT; ! 716: sprintf(q->user.ident, "fmt_%ld", labelval->stateno); ! 717: putout(mkexpr(OPASSIGN, (expptr)p, (expptr)q)); ! 718: } ! 719: ! 720: } /* exassign */ ! 721: ! 722: ! 723: ! 724: exarif(expr, neglab, zerlab, poslab) ! 725: expptr expr; ! 726: struct Labelblock *neglab, *zerlab, *poslab; ! 727: { ! 728: register int lm, lz, lp; ! 729: ! 730: lm = neglab->stateno; ! 731: lz = zerlab->stateno; ! 732: lp = poslab->stateno; ! 733: expr = fixtype(expr); ! 734: ! 735: if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) ) ! 736: { ! 737: err("invalid type of arithmetic if expression"); ! 738: frexpr(expr); ! 739: } ! 740: else ! 741: { ! 742: if (lm == lz && lz == lp) ! 743: exgoto (neglab); ! 744: else if(lm == lz) ! 745: exar2(OPLE, expr, neglab, poslab); ! 746: else if(lm == lp) ! 747: exar2(OPNE, expr, neglab, zerlab); ! 748: else if(lz == lp) ! 749: exar2(OPGE, expr, zerlab, neglab); ! 750: else { ! 751: expptr t; ! 752: ! 753: if (!addressable (expr)) { ! 754: t = (expptr) mktmp(expr -> headblock.vtype, ENULL); ! 755: expr = mkexpr (OPASSIGN, cpexpr (t), expr); ! 756: } else ! 757: t = (expptr) cpexpr (expr); ! 758: ! 759: p1_if(putx(fixtype(mkexpr (OPLT, expr, ICON (0))))); ! 760: exgoto(neglab); ! 761: p1_elif (mkexpr (OPEQ, t, ICON (0))); ! 762: exgoto(zerlab); ! 763: p1_else (); ! 764: exgoto(poslab); ! 765: p1else_end (); ! 766: } /* else */ ! 767: } ! 768: } ! 769: ! 770: ! 771: ! 772: /* exar2 -- Do arithmetic IF for only 2 distinct labels; if !(e.op.0) ! 773: goto l2 else goto l1. If this seems backwards, that's because it is, ! 774: in order to make the 1 pass algorithm work. */ ! 775: ! 776: LOCAL void ! 777: exar2(op, e, l1, l2) ! 778: int op; ! 779: expptr e; ! 780: struct Labelblock *l1, *l2; ! 781: { ! 782: expptr comp; ! 783: ! 784: comp = mkexpr (op, e, ICON (0)); ! 785: p1_if(putx(fixtype(comp))); ! 786: exgoto(l1); ! 787: p1_else (); ! 788: exgoto(l2); ! 789: p1else_end (); ! 790: } ! 791: ! 792: ! 793: /* exreturn -- return the value in p from a SUBROUTINE call -- used to ! 794: implement the alternate return mechanism */ ! 795: ! 796: exreturn(p) ! 797: register expptr p; ! 798: { ! 799: if(procclass != CLPROC) ! 800: warn("RETURN statement in main or block data"); ! 801: if(p && (proctype!=TYSUBR || procclass!=CLPROC) ) ! 802: { ! 803: err("alternate return in nonsubroutine"); ! 804: p = 0; ! 805: } ! 806: ! 807: if (p || proctype == TYSUBR) { ! 808: if (p == ENULL) p = ICON (0); ! 809: p = mkconv (TYLONG, fixtype (p)); ! 810: p1_subr_ret (p); ! 811: } /* if p || proctype == TYSUBR */ ! 812: else ! 813: p1_subr_ret((expptr)retslot); ! 814: } ! 815: ! 816: ! 817: exasgoto(labvar) ! 818: Namep labvar; ! 819: { ! 820: register Addrp p; ! 821: void p1_asgoto(); ! 822: ! 823: p = mkplace(labvar); ! 824: if( ! ISINT(p->vtype) ) ! 825: err("assigned goto variable must be integer"); ! 826: else { ! 827: p1_asgoto (p); ! 828: } /* else */ ! 829: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.