![[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] / researchv8dc / cmd / efl|
Return to simple.c CVS log | Up to [Research Unix] / researchv8dc / 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 = copys(".true."); ! 76: else if(equals(lp->leftp, ".true.")) ! 77: e->leftp = 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: if(tailor.ftn77 && e->vtype==TYINT) ! 214: break; ! 215: if(tag==TAROP && (subtype==OPPLUS || subtype==OPMINUS)) ! 216: if(rp->tag==TCONST && rp->vtype==TYINT) ! 217: { ! 218: if(!cvform(lp)) ! 219: e->leftp = simple(SUBVAL, lp); ! 220: } ! 221: else goto makesub; ! 222: else if( !cvform(e) ) goto makesub; ! 223: } ! 224: break; ! 225: ! 226: case TCALL: ! 227: if( lp->tag!=TFTNBLOCK && ioop(lp->sthead->namep) ) ! 228: { ! 229: e = exioop(e, YES); ! 230: exlab(0); ! 231: break; ! 232: } ! 233: e->rightp = simple(RVAL, rp); ! 234: if(t == SUBVAL) ! 235: goto makesub; ! 236: if(t == LVAL) ! 237: e = simple(RVAL, mknode(TASGNOP,0, gentemp(e),e)); ! 238: break; ! 239: ! 240: ! 241: case TNAME: ! 242: if(e->voffset) ! 243: fixsubs(e); ! 244: if(e->vsubs) ! 245: e->vsubs = simple(SUBVAL, e->vsubs); ! 246: if(t==SUBVAL && !vform(e)) ! 247: goto makesub; ! 248: ! 249: case TTEMP: ! 250: case TFTNBLOCK: ! 251: case TCONST: ! 252: if(t==SUBVAL && e->vtype!=TYINT) ! 253: goto makesub; ! 254: break; ! 255: ! 256: case TASGNOP: ! 257: lp = e->leftp = simple(LVAL,lp); ! 258: if(subtype==OP2OR || subtype==OP2AND) ! 259: e = dblop(e); ! 260: ! 261: else { ! 262: rp = e->rightp = simple(RVAL,rp); ! 263: if(e->vtype == TYCHAR) ! 264: excall(mkcall(mkftnblock(TYSUBR,"ef1asc"), arg4(cpexpr(lp),rp))); ! 265: else if(e->vtype == TYSTRUCT) ! 266: { ! 267: if(lp->vtypep->strsize != rp->vtypep->strsize) ! 268: fatal("simple: attempt to assign incompatible structures"); ! 269: e1 = mkchain(cpexpr(lp),mkchain(rp, ! 270: mkchain(mkint(lp->vtypep->strsize),CHNULL))); ! 271: excall(mkcall(mkftnblock(TYSUBR,"ef1ass"), ! 272: mknode(TLIST, 0, e1, PNULL) )); ! 273: } ! 274: else if(lp->vtype == TYFIELD) ! 275: lp = setfield(e); ! 276: else { ! 277: if(subtype != OPASGN) /* but is one of += etc */ ! 278: { ! 279: rp = e->rightp = simple(RVAL, mknode( ! 280: (subtype<=OPPOWER?TAROP:TLOGOP),subtype, ! 281: cpexpr(e->leftp),e->rightp)); ! 282: e->subtype = OPASGN; ! 283: } ! 284: exlab(0); ! 285: prexpr(e); ! 286: frexpr(rp); ! 287: } ! 288: frexpblock(e); ! 289: e = lp; ! 290: if(t == SUBVAL) goto top; ! 291: } ! 292: ! 293: break; ! 294: ! 295: case TLIST: ! 296: for(p=lp ; p ; p = p->nextp) ! 297: p->datap = simple(t, p->datap); ! 298: break; ! 299: ! 300: case TIOSTAT: ! 301: e = exio(e, 1); ! 302: break; ! 303: ! 304: default: ! 305: break; ! 306: } ! 307: ! 308: return(e); ! 309: ! 310: ! 311: typerr: ! 312: exprerr("type match error", CNULL); ! 313: return(e); ! 314: ! 315: makesub: ! 316: if(t==SUBVAL && e->vtype!=TYINT) ! 317: warn1("Line %d. Non-integer subscript", yylineno); ! 318: return( simple(RVAL, mknode(TASGNOP,0,gent(TYINT,PNULL),e)) ); ! 319: } ! 320: ! 321: ptr fold(e) ! 322: register ptr e; ! 323: { ! 324: int a, b, c; ! 325: register ptr lp, rp; ! 326: ! 327: lp = e->leftp; ! 328: rp = e->rightp; ! 329: ! 330: if(lp->tag!=TCONST && lp->tag!=TNEGOP) ! 331: return(e); ! 332: ! 333: if(rp->tag!=TCONST && rp->tag!=TNEGOP) ! 334: return(e); ! 335: ! 336: ! 337: switch(e->tag) ! 338: { ! 339: case TAROP: ! 340: if( !isicon(lp,&a) || !isicon(rp,&b) ) ! 341: return(e); ! 342: ! 343: switch(e->subtype) ! 344: { ! 345: case OPPLUS: ! 346: c = a + b;break; ! 347: case OPMINUS: ! 348: c = a - b; break; ! 349: case OPSTAR: ! 350: c = a * b; break; ! 351: case OPSLASH: ! 352: if(a%b!=0 && (a<0 || b<0) ) ! 353: return(e); ! 354: c = a / b; break; ! 355: case OPPOWER: ! 356: return(e); ! 357: default: ! 358: fatal("fold: illegal binary operator"); ! 359: } ! 360: frexpr(e); ! 361: ! 362: if(c >= 0) ! 363: return( mkint(c) ); ! 364: else return(mknode(TNEGOP,OPMINUS, mkint(-c), PNULL) ); ! 365: ! 366: case TRELOP: ! 367: if( !isicon(lp,&a) || !isicon(rp,&b) ) ! 368: return(e); ! 369: frexpr(e); ! 370: ! 371: switch(e->subtype) ! 372: { ! 373: case OPEQ: ! 374: c = a == b; break; ! 375: case OPLT: ! 376: c = a < b ; break; ! 377: case OPGT: ! 378: c = a > b; break; ! 379: case OPLE: ! 380: c = a <= b; break; ! 381: case OPGE: ! 382: c = a >= b; break; ! 383: case OPNE: ! 384: c = a != b; break; ! 385: default: ! 386: fatal("fold: invalid relational operator"); ! 387: } ! 388: return( mkconst(TYLOG, (c ? ".true." : ".false.")) ); ! 389: ! 390: ! 391: case TLOGOP: ! 392: if(lp->vtype!=TYLOG || rp->vtype!=TYLOG) ! 393: return(e); ! 394: a = equals(lp->leftp, ".true."); ! 395: b = equals(rp->leftp, ".true."); ! 396: frexpr(e); ! 397: ! 398: switch(e->subtype) ! 399: { ! 400: case OPAND: ! 401: case OP2AND: ! 402: c = a & b; break; ! 403: case OPOR: ! 404: case OP2OR: ! 405: c = a | b; break; ! 406: default: ! 407: fatal("fold: invalid logical operator"); ! 408: } ! 409: return( mkconst(TYLOG, (c? ".true." : ".false")) ); ! 410: ! 411: default: ! 412: return(e); ! 413: } ! 414: } ! 415: ! 416: #define TO + 100* ! 417: ! 418: ! 419: ptr coerce(t,e) /* coerce expression e to type t */ ! 420: int t; ! 421: register ptr e; ! 422: { ! 423: register int et; ! 424: int econst; ! 425: char buff[100]; ! 426: char *s, *s1; ! 427: ptr conrep(), xfixf(); ! 428: ! 429: if(e->tag == TNEGOP) ! 430: { ! 431: e->leftp = coerce(t, e->leftp); ! 432: goto settype; ! 433: } ! 434: ! 435: et = e->vtype; ! 436: econst = (e->tag == TCONST); ! 437: TEST fprintf(diagfile, "coerce type %d to type %d\n", et, t); ! 438: if(t == et) ! 439: return(e); ! 440: ! 441: switch( et TO t ) ! 442: { ! 443: case TYCOMPLEX TO TYINT: ! 444: case TYLREAL TO TYINT: ! 445: e = coerce(TYREAL,e); ! 446: case TYREAL TO TYINT: ! 447: if(econst) ! 448: e = xfixf(e); ! 449: if(e->vtype != TYINT) ! 450: e = mkcall(builtin(TYINT,"ifix"), arg1(e)); ! 451: break; ! 452: ! 453: case TYINT TO TYREAL: ! 454: if(econst) ! 455: { ! 456: e->leftp = conrep(e->leftp, "."); ! 457: goto settype; ! 458: } ! 459: e = mkcall(builtin(TYREAL,"float"), arg1(e)); ! 460: break; ! 461: ! 462: case TYLREAL TO TYREAL: ! 463: if(econst) ! 464: { ! 465: for(s=e->leftp ; *s && *s!='d';++s) ! 466: ; ! 467: *s = 'e'; ! 468: goto settype; ! 469: } ! 470: e = mkcall(builtin(TYREAL,"sngl"), arg1(e)); ! 471: break; ! 472: ! 473: case TYCOMPLEX TO TYREAL: ! 474: if(econst) ! 475: { ! 476: s1 = (char *)(e->leftp) + 1; ! 477: s = buff; ! 478: while(*s1!=',' && *s1!='\0') ! 479: *s1++ = *s++; ! 480: *s = '\0'; ! 481: cfree(e->leftp); ! 482: e->leftp = copys(buff); ! 483: goto settype; ! 484: } ! 485: else ! 486: e = mkcall(mkftnblock(TYREAL,"real"), arg1(e)); ! 487: break; ! 488: ! 489: case TYINT TO TYLREAL: ! 490: if(econst) ! 491: { ! 492: e->leftp = conrep(e->leftp,"d0"); ! 493: goto settype; ! 494: } ! 495: case TYCOMPLEX TO TYLREAL: ! 496: e = coerce(TYREAL,e); ! 497: case TYREAL TO TYLREAL: ! 498: if(econst) ! 499: { ! 500: for(s=e->leftp ; *s && *s!='e'; ++s) ! 501: ; ! 502: if(*s == 'e') ! 503: *s = 'd'; ! 504: else e->leftp = conrep(e->leftp,"d0"); ! 505: goto settype; ! 506: } ! 507: e = mkcall(builtin(TYLREAL,"dble"), arg1(e)); ! 508: break; ! 509: ! 510: case TYINT TO TYCOMPLEX: ! 511: case TYLREAL TO TYCOMPLEX: ! 512: e = coerce(TYREAL, e); ! 513: case TYREAL TO TYCOMPLEX: ! 514: if(e->tag == TCONST) ! 515: { ! 516: sprintf(buff, "(%s,0.)", e->leftp); ! 517: cfree(e->leftp); ! 518: e->leftp = copys(buff); ! 519: goto settype; ! 520: } ! 521: else ! 522: e = mkcall(builtin(TYCOMPLEX,"cmplx"), ! 523: arg2(e, mkconst(TYREAL,"0."))); ! 524: break; ! 525: ! 526: ! 527: default: ! 528: goto mismatch; ! 529: } ! 530: ! 531: return(e); ! 532: ! 533: ! 534: mismatch: ! 535: exprerr("impossible conversion", ""); ! 536: frexpr(e); ! 537: return( errnode() ); ! 538: ! 539: ! 540: settype: ! 541: e->vtype = t; ! 542: return(e); ! 543: } ! 544: ! 545: ! 546: ! 547: /* check whether expression is in form c, v, or v*c */ ! 548: cvform(p) ! 549: register ptr p; ! 550: { ! 551: switch(p->tag) ! 552: { ! 553: case TCONST: ! 554: return(p->vtype == TYINT); ! 555: ! 556: case TNAME: ! 557: return(vform(p)); ! 558: ! 559: case TAROP: ! 560: if(p->subtype==OPSTAR && p->rightp->tag==TCONST ! 561: && p->rightp->vtype==TYINT && vform(p->leftp)) ! 562: return(1); ! 563: ! 564: default: ! 565: return(0); ! 566: } ! 567: } ! 568: ! 569: ! 570: ! 571: ! 572: /* is p a simple integer variable */ ! 573: vform(p) ! 574: register ptr p; ! 575: { ! 576: return( p->tag==TNAME && p->vtype==TYINT && p->vdim==0 ! 577: && p->voffset==0 && p->vsubs==0) ; ! 578: } ! 579: ! 580: ! 581: ! 582: ptr dblop(p) ! 583: ptr p; ! 584: { ! 585: ptr q; ! 586: ! 587: bgnexec(); ! 588: if(p->subtype == OP2OR) ! 589: q = mknode(TNOTOP,OPNOT, cpexpr(p->leftp), PNULL); ! 590: else q = cpexpr(p->leftp); ! 591: ! 592: pushctl(STIF, q); ! 593: bgnexec(); ! 594: exasgn(cpexpr(p->leftp), OPASGN, p->rightp); ! 595: ifthen(); ! 596: popctl(); ! 597: addexec(); ! 598: return(p->leftp); ! 599: } ! 600: ! 601: ! 602: ! 603: ! 604: divides(a,b) ! 605: ptr a; ! 606: int b; ! 607: { ! 608: if(a->vtype!=TYINT) ! 609: return(0); ! 610: ! 611: switch(a->tag) ! 612: { ! 613: case TNEGOP: ! 614: return( divides(a->leftp,b) ); ! 615: ! 616: case TCONST: ! 617: return( conval(a) % b == 0); ! 618: ! 619: case TAROP: ! 620: switch(a->subtype) ! 621: { ! 622: case OPPLUS: ! 623: case OPMINUS: ! 624: return(divides(a->leftp,b)&& ! 625: divides(a->rightp,b) ); ! 626: ! 627: case OPSTAR: ! 628: return(divides(a->rightp,b)); ! 629: ! 630: default: ! 631: return(0); ! 632: } ! 633: default: ! 634: return(0); ! 635: } ! 636: /* NOTREACHED */ ! 637: } ! 638: ! 639: /* truncate floating point constant to integer */ ! 640: ! 641: #define MAXD 100 ! 642: ! 643: ptr xfixf(e) ! 644: struct exprblock *e; ! 645: { ! 646: char digit[MAXD+1]; /* buffer into which digits are placed */ ! 647: char *first; /* points to first nonzero digit */ ! 648: register char *end; /* points at position past last digit */ ! 649: register char *dot; /* decimal point is immediately to left of this digit */ ! 650: register char *s; ! 651: int expon; ! 652: ! 653: dot = NULL; ! 654: end = digit; ! 655: expon = 0; ! 656: ! 657: for(s = e->leftp ; *s; ++s) ! 658: if( isdigit(*s) ) ! 659: { ! 660: if(end-digit > MAXD) ! 661: return(e); ! 662: *end++ = *s; ! 663: } ! 664: else if(*s == '.') ! 665: dot = end; ! 666: else if(*s=='d' || *s=='e') ! 667: { ! 668: expon = convci(s+1); ! 669: break; ! 670: } ! 671: else fatal1("impossible character %d in floating constant", *s); ! 672: ! 673: if(dot == NULL) ! 674: dot = end; ! 675: dot += expon; ! 676: if(dot-digit > MAXD) ! 677: return(e); ! 678: for(first = digit; first<end && *first=='0' ; ++first) ! 679: ; ! 680: if(dot<=first) ! 681: { ! 682: dot = first+1; ! 683: *first = '0'; ! 684: } ! 685: else while(end < dot) ! 686: *end++ = '0'; ! 687: *dot = '\0'; ! 688: cfree(e->leftp); ! 689: e->leftp = copys(first); ! 690: e->vtype = TYINT; ! 691: return(e); ! 692: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.