4.3BSD - /usr/src/usr.bin/efl/simple.c

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

Defined functions

Defined macros