![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to simple.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / efl|
Return to simple.c CVS log | Up to [Research Unix] / researchv10no / cmd / efl |
1.1 ! root 1: #include <ctype.h> ! 2: #include "defs" ! 3: ! 4: ! 5: /* basic simplifying procedure */ ! 6: ! 7: ptr simple(t,e) ! 8: int t; /* take on the values LVAL, RVAL, and SUBVAL */ ! 9: register ptr e; /* points to an expression */ ! 10: { ! 11: int tag, subtype; ! 12: ptr lp, rp; ! 13: int ltag; ! 14: int lsubt; ! 15: ptr p, e1; ! 16: ptr exio(), exioop(), dblop(), setfield(), gentemp(); ! 17: int a,b,c; ! 18: ! 19: top: ! 20: ! 21: if(e == 0) return(0); ! 22: ! 23: tag = e->tag; ! 24: subtype = e->subtype; ! 25: if(lp = e->leftp) ! 26: { ! 27: ltag = lp->tag; ! 28: lsubt = lp->subtype; ! 29: } ! 30: rp = e->rightp; ! 31: ! 32: TEST fprintf(diagfile, "simple(%d; tag %d,%d)\n", t,tag,subtype); ! 33: ! 34: switch(tag){ ! 35: ! 36: case TNOTOP: ! 37: switch(ltag) { ! 38: ! 39: case TNOTOP: /* not not = yes */ ! 40: frexpblock(e); ! 41: e = lp->leftp; ! 42: frexpblock(lp); ! 43: goto top; ! 44: ! 45: case TLOGOP: /* de Morgan's Law */ ! 46: lp->subtype = (OPOR+OPAND) - lp->subtype; ! 47: lp->leftp = mknode(TNOTOP,OPNOT,lp->leftp, PNULL); ! 48: lp->rightp=mknode(TNOTOP,OPNOT,lp->rightp, PNULL); ! 49: frexpblock(e); ! 50: e = lp; ! 51: goto top; ! 52: ! 53: case TRELOP: /* reverse the condition */ ! 54: lp->subtype = (OPEQ+OPNE) - lp->subtype; ! 55: frexpblock(e); ! 56: e = lp; ! 57: goto top; ! 58: ! 59: case TCALL: ! 60: case TASGNOP: ! 61: e->leftp = simple(RVAL,lp); ! 62: ! 63: case TNAME: ! 64: case TFTNBLOCK: ! 65: lp = simple(RVAL,lp); ! 66: ! 67: case TTEMP: ! 68: if(t == LVAL) ! 69: e = simple(LVAL, ! 70: mknode(TASGNOP,0, gentemp(e->leftp), e)); ! 71: break; ! 72: ! 73: case TCONST: ! 74: if(equals(lp->leftp, ".false.")) ! 75: e->leftp = (int *)copys(".true."); ! 76: else if(equals(lp->leftp, ".true.")) ! 77: e->leftp = (int *)copys(".false."); ! 78: else goto typerr; ! 79: ! 80: e->tag = TCONST; ! 81: e->subtype = 0; ! 82: cfree(lp->leftp); ! 83: frexpblock(lp); ! 84: break; ! 85: ! 86: default: goto typerr; ! 87: } ! 88: break; ! 89: ! 90: ! 91: ! 92: ! 93: case TLOGOP: switch(subtype) { ! 94: case OPOR: ! 95: case OPAND: ! 96: goto binop; ! 97: ! 98: case OP2OR: ! 99: case OP2AND: ! 100: lp = e->leftp = simple(RVAL, lp); ! 101: if(lp->tag != TTEMP) ! 102: lp = simple(RVAL, ! 103: mknode(TASGNOP,0, gent(TYLOG,0),lp)); ! 104: return( simple(LVAL, mknode(TASGNOP,subtype,lp,rp)) ); ! 105: default: ! 106: fatal("impossible logical operator"); ! 107: } ! 108: ! 109: case TNEGOP: ! 110: lp = e->leftp = simple(RVAL,lp); ! 111: ltag = lp->tag; ! 112: lsubt = lp->subtype; ! 113: ! 114: if(ltag==TNEGOP) ! 115: { ! 116: frexpblock(e); ! 117: e = lp->leftp; ! 118: frexpblock(lp); ! 119: goto top; ! 120: } ! 121: else goto lvcheck; ! 122: ! 123: case TAROP: ! 124: case TRELOP: ! 125: ! 126: binop: ! 127: ! 128: e->leftp = simple(RVAL,lp); ! 129: lp = e->leftp; ! 130: ltag = lp->tag; ! 131: lsubt = lp->subtype; ! 132: ! 133: e->rightp= simple(RVAL,rp); ! 134: rp = e->rightp; ! 135: ! 136: if(tag==TAROP && isicon(rp,&b) ) ! 137: { /* simplify a*1, a/1 , a+0, a-0 */ ! 138: if( ((subtype==OPSTAR||subtype==OPSLASH) && b==1) || ! 139: ((subtype==OPPLUS||subtype==OPMINUS) && b==0) ) ! 140: { ! 141: frexpr(rp); ! 142: mvexpr(lp,e); ! 143: goto top; ! 144: } ! 145: ! 146: if(isicon(lp, &a)) /* try folding const op const */ ! 147: { ! 148: e1 = fold(e); ! 149: if(e1!=e || e1->tag!=TAROP) ! 150: { ! 151: e = e1; ! 152: goto top; ! 153: } ! 154: } ! 155: if(ltag==TAROP && lp->needpar==0 && isicon(lp->rightp,&a) ) ! 156: { /* look for cases of (e op const ) op' const */ ! 157: ! 158: if( (subtype==OPPLUS||subtype==OPMINUS) && ! 159: (lsubt==OPPLUS||lsubt==OPMINUS) ) ! 160: { /* (e +- const) +- const */ ! 161: c = (subtype==OPPLUS ? 1 : -1) * b + ! 162: (lsubt==OPPLUS? 1 : -1) * a; ! 163: if(c > 0) ! 164: subtype = OPPLUS; ! 165: else { ! 166: subtype = OPMINUS; ! 167: c = -c; ! 168: } ! 169: fixexpr: ! 170: frexpr(rp); ! 171: frexpr(lp->rightp); ! 172: frexpblock(e); ! 173: e = lp; ! 174: e->subtype = subtype; ! 175: e->rightp = mkint(c); ! 176: goto top; ! 177: } ! 178: ! 179: else if(lsubt==OPSTAR && ! 180: ( (subtype==OPSTAR) || ! 181: (subtype==OPSLASH && a%b==0)) ) ! 182: { /* (e * const ) (* or /) const */ ! 183: c = (subtype==OPSTAR ? a*b : a/b ); ! 184: subtype = OPSTAR; ! 185: goto fixexpr; ! 186: } ! 187: } ! 188: if(ltag==TAROP && (lsubt==OPPLUS || lsubt==OPMINUS) && ! 189: subtype==OPSLASH && divides(lp,conval(rp)) ) ! 190: { ! 191: e->leftp = mknode(TAROP,OPSLASH,lp->leftp, cpexpr(rp)); ! 192: e->rightp = mknode(TAROP,OPSLASH,lp->rightp, rp); ! 193: e->subtype = lsubt; ! 194: goto top; ! 195: } ! 196: } ! 197: ! 198: else if( tag==TRELOP && isicon(lp,&a) && isicon(rp,&b) ) ! 199: { ! 200: e1 = fold(e); ! 201: if(e1!=e || e1->tag!=TRELOP) ! 202: { ! 203: e = e1; ! 204: goto top; ! 205: } ! 206: } ! 207: ! 208: lvcheck: ! 209: if(t == LVAL) ! 210: e = simple(LVAL, mknode(TASGNOP,0, gentemp(e),e)); ! 211: else if(t == SUBVAL) ! 212: { /* test for legal Fortran c*v +-c form */ ! 213: /* ! 214: if(tailor.ftn77 && e->vtype==TYINT) ! 215: break; ! 216: */ ! 217: if(tag==TAROP && (subtype==OPPLUS || subtype==OPMINUS)) ! 218: if(rp->tag==TCONST && rp->vtype==TYINT) ! 219: { ! 220: if(!cvform(lp)) ! 221: e->leftp = simple(SUBVAL, lp); ! 222: } ! 223: else goto makesub; ! 224: else if( !cvform(e) ) goto makesub; ! 225: } ! 226: break; ! 227: ! 228: case TCALL: ! 229: if( lp->tag!=TFTNBLOCK && ioop(((struct stentry *)lp->sthead)->namep) ) ! 230: { ! 231: e = exioop(e, YES); ! 232: exlab(0); ! 233: break; ! 234: } ! 235: e->rightp = simple(RVAL, rp); ! 236: if(t == SUBVAL) ! 237: goto makesub; ! 238: if(t == LVAL) ! 239: e = simple(RVAL, mknode(TASGNOP,0, gentemp(e),e)); ! 240: break; ! 241: ! 242: ! 243: case TNAME: ! 244: if(e->voffset) ! 245: fixsubs(e); ! 246: if(e->vsubs) ! 247: e->vsubs = simple(SUBVAL, e->vsubs); ! 248: if(t==SUBVAL && !vform(e)) ! 249: goto makesub; ! 250: ! 251: case TTEMP: ! 252: case TFTNBLOCK: ! 253: case TCONST: ! 254: if(t==SUBVAL && e->vtype!=TYINT) ! 255: goto makesub; ! 256: break; ! 257: ! 258: case TASGNOP: ! 259: lp = e->leftp = simple(LVAL,lp); ! 260: if(subtype==OP2OR || subtype==OP2AND) ! 261: e = dblop(e); ! 262: ! 263: else { ! 264: rp = e->rightp = simple(RVAL,rp); ! 265: if(e->vtype == TYCHAR) ! 266: excall(mkcall(mkftnblock(TYSUBR,"ef1asc"), arg4(cpexpr(lp),rp))); ! 267: else if(e->vtype == TYSTRUCT) ! 268: { ! 269: if(((struct typeblock *)lp->vtypep)->strsize != ((struct typeblock *)rp->vtypep)->strsize) ! 270: fatal("simple: attempt to assign incompatible structures"); ! 271: e1 = (int *)mkchain(cpexpr(lp),mkchain(rp, ! 272: mkchain(mkint(((struct typeblock *)lp->vtypep)->strsize),CHNULL))); ! 273: excall(mkcall(mkftnblock(TYSUBR,"ef1ass"), ! 274: mknode(TLIST, 0, e1, PNULL) )); ! 275: } ! 276: else if(lp->vtype == TYFIELD) ! 277: lp = setfield(e); ! 278: else { ! 279: if(subtype != OPASGN) /* but is one of += etc */ ! 280: { ! 281: rp = e->rightp = simple(RVAL, mknode( ! 282: (subtype<=OPPOWER?TAROP:TLOGOP),subtype, ! 283: cpexpr(e->leftp),e->rightp)); ! 284: e->subtype = OPASGN; ! 285: } ! 286: exlab(0); ! 287: prexpr(e); ! 288: frexpr(rp); ! 289: } ! 290: frexpblock(e); ! 291: e = lp; ! 292: if(t == SUBVAL) goto top; ! 293: } ! 294: ! 295: break; ! 296: ! 297: case TLIST: ! 298: for(p=lp ; p ; p = p->nextp) ! 299: p->datap = simple(t, p->datap); ! 300: break; ! 301: ! 302: case TIOSTAT: ! 303: e = exio(e, 1); ! 304: break; ! 305: ! 306: default: ! 307: break; ! 308: } ! 309: ! 310: return(e); ! 311: ! 312: ! 313: typerr: ! 314: exprerr("type match error", CNULL); ! 315: return(e); ! 316: ! 317: makesub: ! 318: if(t==SUBVAL && e->vtype!=TYINT) ! 319: warn1("Line %d. Non-integer subscript", yylineno); ! 320: return( simple(RVAL, mknode(TASGNOP,0,gent(TYINT,PNULL),e)) ); ! 321: } ! 322: ! 323: ptr fold(e) ! 324: register ptr e; ! 325: { ! 326: int a, b, c; ! 327: register ptr lp, rp; ! 328: ! 329: lp = e->leftp; ! 330: rp = e->rightp; ! 331: ! 332: if(lp->tag!=TCONST && lp->tag!=TNEGOP) ! 333: return(e); ! 334: ! 335: if(rp->tag!=TCONST && rp->tag!=TNEGOP) ! 336: return(e); ! 337: ! 338: ! 339: switch(e->tag) ! 340: { ! 341: case TAROP: ! 342: if( !isicon(lp,&a) || !isicon(rp,&b) ) ! 343: return(e); ! 344: ! 345: switch(e->subtype) ! 346: { ! 347: case OPPLUS: ! 348: c = a + b;break; ! 349: case OPMINUS: ! 350: c = a - b; break; ! 351: case OPSTAR: ! 352: c = a * b; break; ! 353: case OPSLASH: ! 354: if(a%b!=0 && (a<0 || b<0) ) ! 355: return(e); ! 356: c = a / b; break; ! 357: case OPPOWER: ! 358: return(e); ! 359: default: ! 360: fatal("fold: illegal binary operator"); ! 361: } ! 362: frexpr(e); ! 363: ! 364: if(c >= 0) ! 365: return( mkint(c) ); ! 366: else return(mknode(TNEGOP,OPMINUS, mkint(-c), PNULL) ); ! 367: ! 368: case TRELOP: ! 369: if( !isicon(lp,&a) || !isicon(rp,&b) ) ! 370: return(e); ! 371: frexpr(e); ! 372: ! 373: switch(e->subtype) ! 374: { ! 375: case OPEQ: ! 376: c = a == b; break; ! 377: case OPLT: ! 378: c = a < b ; break; ! 379: case OPGT: ! 380: c = a > b; break; ! 381: case OPLE: ! 382: c = a <= b; break; ! 383: case OPGE: ! 384: c = a >= b; break; ! 385: case OPNE: ! 386: c = a != b; break; ! 387: default: ! 388: fatal("fold: invalid relational operator"); ! 389: } ! 390: return( mkconst(TYLOG, (c ? ".true." : ".false.")) ); ! 391: ! 392: ! 393: case TLOGOP: ! 394: if(lp->vtype!=TYLOG || rp->vtype!=TYLOG) ! 395: return(e); ! 396: a = equals(lp->leftp, ".true."); ! 397: b = equals(rp->leftp, ".true."); ! 398: frexpr(e); ! 399: ! 400: switch(e->subtype) ! 401: { ! 402: case OPAND: ! 403: case OP2AND: ! 404: c = a & b; break; ! 405: case OPOR: ! 406: case OP2OR: ! 407: c = a | b; break; ! 408: default: ! 409: fatal("fold: invalid logical operator"); ! 410: } ! 411: return( mkconst(TYLOG, (c? ".true." : ".false")) ); ! 412: ! 413: default: ! 414: return(e); ! 415: } ! 416: } ! 417: ! 418: #define TO + 100* ! 419: ! 420: ! 421: ptr coerce(t,e) /* coerce expression e to type t */ ! 422: int t; ! 423: register ptr e; ! 424: { ! 425: register int et; ! 426: int econst; ! 427: char buff[100]; ! 428: char *s, *s1; ! 429: ptr conrep(), xfixf(); ! 430: ! 431: if(e->tag == TNEGOP) ! 432: { ! 433: e->leftp = coerce(t, e->leftp); ! 434: goto settype; ! 435: } ! 436: ! 437: et = e->vtype; ! 438: econst = (e->tag == TCONST); ! 439: TEST fprintf(diagfile, "coerce type %d to type %d\n", et, t); ! 440: if(t == et) ! 441: return(e); ! 442: ! 443: switch( et TO t ) ! 444: { ! 445: case TYCOMPLEX TO TYINT: ! 446: case TYLREAL TO TYINT: ! 447: e = coerce(TYREAL,e); ! 448: case TYREAL TO TYINT: ! 449: if(econst) ! 450: e = xfixf(e); ! 451: if(e->vtype != TYINT) ! 452: e = mkcall(builtin(TYINT,"ifix"), arg1(e)); ! 453: break; ! 454: ! 455: case TYINT TO TYREAL: ! 456: if(econst) ! 457: { ! 458: e->leftp = conrep(e->leftp, "."); ! 459: goto settype; ! 460: } ! 461: e = mkcall(builtin(TYREAL,"float"), arg1(e)); ! 462: break; ! 463: ! 464: case TYLREAL TO TYREAL: ! 465: if(econst) ! 466: { ! 467: for(s=(char *)e->leftp ; *s && *s!='d';++s) ! 468: ; ! 469: *s = 'e'; ! 470: goto settype; ! 471: } ! 472: e = mkcall(builtin(TYREAL,"sngl"), arg1(e)); ! 473: break; ! 474: ! 475: case TYCOMPLEX TO TYREAL: ! 476: if(econst) ! 477: { ! 478: s1 = (char *)(e->leftp) + 1; ! 479: s = buff; ! 480: while(*s1!=',' && *s1!='\0') ! 481: *s1++ = *s++; ! 482: *s = '\0'; ! 483: cfree(e->leftp); ! 484: e->leftp = (int *)copys(buff); ! 485: goto settype; ! 486: } ! 487: else ! 488: e = mkcall(mkftnblock(TYREAL,"real"), arg1(e)); ! 489: break; ! 490: ! 491: case TYINT TO TYLREAL: ! 492: if(econst) ! 493: { ! 494: e->leftp = conrep(e->leftp,"d0"); ! 495: goto settype; ! 496: } ! 497: case TYCOMPLEX TO TYLREAL: ! 498: e = coerce(TYREAL,e); ! 499: case TYREAL TO TYLREAL: ! 500: if(econst) ! 501: { ! 502: for(s=(char *)e->leftp ; *s && *s!='e'; ++s) ! 503: ; ! 504: if(*s == 'e') ! 505: *s = 'd'; ! 506: else e->leftp = conrep(e->leftp,"d0"); ! 507: goto settype; ! 508: } ! 509: e = mkcall(builtin(TYLREAL,"dble"), arg1(e)); ! 510: break; ! 511: ! 512: case TYINT TO TYCOMPLEX: ! 513: case TYLREAL TO TYCOMPLEX: ! 514: e = coerce(TYREAL, e); ! 515: case TYREAL TO TYCOMPLEX: ! 516: if(e->tag == TCONST) ! 517: { ! 518: sprintf(buff, "(%s,0.)", e->leftp); ! 519: cfree(e->leftp); ! 520: e->leftp = (int *)copys(buff); ! 521: goto settype; ! 522: } ! 523: else ! 524: e = mkcall(builtin(TYCOMPLEX,"cmplx"), ! 525: arg2(e, mkconst(TYREAL,"0."))); ! 526: break; ! 527: ! 528: ! 529: default: ! 530: goto mismatch; ! 531: } ! 532: ! 533: return(e); ! 534: ! 535: ! 536: mismatch: ! 537: exprerr("impossible conversion", ""); ! 538: frexpr(e); ! 539: return( errnode() ); ! 540: ! 541: ! 542: settype: ! 543: e->vtype = t; ! 544: return(e); ! 545: } ! 546: ! 547: ! 548: ! 549: /* check whether expression is in form c, v, or v*c */ ! 550: cvform(p) ! 551: register ptr p; ! 552: { ! 553: switch(p->tag) ! 554: { ! 555: case TCONST: ! 556: return(p->vtype == TYINT); ! 557: ! 558: case TNAME: ! 559: return(vform(p)); ! 560: ! 561: case TAROP: ! 562: if(p->subtype==OPSTAR && ((struct headbits *)p->rightp)->tag==TCONST ! 563: && ((struct exprblock *)p->rightp)->vtype==TYINT && vform(p->leftp)) ! 564: return(1); ! 565: ! 566: default: ! 567: return(0); ! 568: } ! 569: } ! 570: ! 571: ! 572: ! 573: ! 574: /* is p a simple integer variable */ ! 575: vform(p) ! 576: register ptr p; ! 577: { ! 578: return( p->tag==TNAME && p->vtype==TYINT && p->vdim==0 ! 579: && p->voffset==0 && p->vsubs==0) ; ! 580: } ! 581: ! 582: ! 583: ! 584: ptr dblop(p) ! 585: ptr p; ! 586: { ! 587: ptr q; ! 588: ! 589: bgnexec(); ! 590: if(p->subtype == OP2OR) ! 591: q = mknode(TNOTOP,OPNOT, cpexpr(p->leftp), PNULL); ! 592: else q = cpexpr(p->leftp); ! 593: ! 594: pushctl(STIF, q); ! 595: bgnexec(); ! 596: exasgn(cpexpr(p->leftp), OPASGN, p->rightp); ! 597: ifthen(); ! 598: popctl(); ! 599: addexec(); ! 600: return(p->leftp); ! 601: } ! 602: ! 603: ! 604: ! 605: ! 606: divides(a,b) ! 607: ptr a; ! 608: int b; ! 609: { ! 610: if(a->vtype!=TYINT) ! 611: return(0); ! 612: ! 613: switch(a->tag) ! 614: { ! 615: case TNEGOP: ! 616: return( divides(a->leftp,b) ); ! 617: ! 618: case TCONST: ! 619: return( conval(a) % b == 0); ! 620: ! 621: case TAROP: ! 622: switch(a->subtype) ! 623: { ! 624: case OPPLUS: ! 625: case OPMINUS: ! 626: return(divides(a->leftp,b)&& ! 627: divides(a->rightp,b) ); ! 628: ! 629: case OPSTAR: ! 630: return(divides(a->rightp,b)); ! 631: ! 632: default: ! 633: return(0); ! 634: } ! 635: default: ! 636: return(0); ! 637: } ! 638: /* NOTREACHED */ ! 639: } ! 640: ! 641: /* truncate floating point constant to integer */ ! 642: ! 643: #define MAXD 100 ! 644: ! 645: ptr xfixf(e) ! 646: struct exprblock *e; ! 647: { ! 648: char digit[MAXD+1]; /* buffer into which digits are placed */ ! 649: char *first; /* points to first nonzero digit */ ! 650: register char *end; /* points at position past last digit */ ! 651: register char *dot; /* decimal point is immediately to left of this digit */ ! 652: register char *s; ! 653: int expon; ! 654: ! 655: dot = NULL; ! 656: end = digit; ! 657: expon = 0; ! 658: ! 659: for(s = (char *)e->leftp ; *s; ++s) ! 660: if( isdigit(*s) ) ! 661: { ! 662: if(end-digit > MAXD) ! 663: return((int *)e); ! 664: *end++ = *s; ! 665: } ! 666: else if(*s == '.') ! 667: dot = end; ! 668: else if(*s=='d' || *s=='e') ! 669: { ! 670: expon = convci(s+1); ! 671: break; ! 672: } ! 673: else fatal1("impossible character %d in floating constant", *s); ! 674: ! 675: if(dot == NULL) ! 676: dot = end; ! 677: dot += expon; ! 678: if(dot-digit > MAXD) ! 679: return((int *)e); ! 680: for(first = digit; first<end && *first=='0' ; ++first) ! 681: ; ! 682: if(dot<=first) ! 683: { ! 684: dot = first+1; ! 685: *first = '0'; ! 686: } ! 687: else while(end < dot) ! 688: *end++ = '0'; ! 689: *dot = '\0'; ! 690: cfree(e->leftp); ! 691: e->leftp = (int *)copys(first); ! 692: e->vtype = TYINT; ! 693: return((int *)e); ! 694: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.