![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to rval.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 40BSD / cmd / pi|
Return to rval.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / pi |
1.1 ! root 1: /* Copyright (c) 1979 Regents of the University of California */ ! 2: ! 3: static char sccsid[] = "@(#)rval.c 1.5 10/28/80"; ! 4: ! 5: #include "whoami.h" ! 6: #include "0.h" ! 7: #include "tree.h" ! 8: #include "opcode.h" ! 9: #include "objfmt.h" ! 10: #ifdef PC ! 11: # include "pc.h" ! 12: # include "pcops.h" ! 13: #endif PC ! 14: ! 15: extern char *opnames[]; ! 16: ! 17: /* line number of the last record comparison warning */ ! 18: short reccompline = 0; ! 19: ! 20: #ifdef PC ! 21: char *relts[] = { ! 22: "_RELEQ" , "_RELNE" , ! 23: "_RELTLT" , "_RELTGT" , ! 24: "_RELTLE" , "_RELTGE" ! 25: }; ! 26: char *relss[] = { ! 27: "_RELEQ" , "_RELNE" , ! 28: "_RELSLT" , "_RELSGT" , ! 29: "_RELSLE" , "_RELSGE" ! 30: }; ! 31: long relops[] = { ! 32: P2EQ , P2NE , ! 33: P2LT , P2GT , ! 34: P2LE , P2GE ! 35: }; ! 36: long mathop[] = { P2MUL , P2PLUS , P2MINUS }; ! 37: char *setop[] = { "_MULT" , "_ADDT" , "_SUBT" }; ! 38: #endif PC ! 39: /* ! 40: * Rvalue - an expression. ! 41: * ! 42: * Contype is the type that the caller would prefer, nand is important ! 43: * if constant sets or constant strings are involved, the latter ! 44: * because of string padding. ! 45: * required is a flag whether an lvalue or an rvalue is required. ! 46: * only VARs and structured things can have gt their lvalue this way. ! 47: */ ! 48: struct nl * ! 49: rvalue(r, contype , required ) ! 50: int *r; ! 51: struct nl *contype; ! 52: int required; ! 53: { ! 54: register struct nl *p, *p1; ! 55: register struct nl *q; ! 56: int c, c1, *rt, w, g; ! 57: char *cp, *cp1, *opname; ! 58: long l; ! 59: double f; ! 60: extern int flagwas; ! 61: struct csetstr csetd; ! 62: # ifdef PC ! 63: struct nl *rettype; ! 64: long ctype; ! 65: long tempoff; ! 66: # endif PC ! 67: ! 68: if (r == NIL) ! 69: return (NIL); ! 70: if (nowexp(r)) ! 71: return (NIL); ! 72: /* ! 73: * Pick up the name of the operation ! 74: * for future error messages. ! 75: */ ! 76: if (r[0] <= T_IN) ! 77: opname = opnames[r[0]]; ! 78: ! 79: /* ! 80: * The root of the tree tells us what sort of expression we have. ! 81: */ ! 82: switch (r[0]) { ! 83: ! 84: /* ! 85: * The constant nil ! 86: */ ! 87: case T_NIL: ! 88: # ifdef OBJ ! 89: put(2, O_CON2, 0); ! 90: # endif OBJ ! 91: # ifdef PC ! 92: putleaf( P2ICON , 0 , 0 , P2PTR|P2UNDEF , 0 ); ! 93: # endif PC ! 94: return (nl+TNIL); ! 95: ! 96: /* ! 97: * Function call with arguments. ! 98: */ ! 99: case T_FCALL: ! 100: # ifdef OBJ ! 101: return (funccod(r)); ! 102: # endif OBJ ! 103: # ifdef PC ! 104: return (pcfunccod( r )); ! 105: # endif PC ! 106: ! 107: case T_VAR: ! 108: p = lookup(r[2]); ! 109: if (p == NIL || p->class == BADUSE) ! 110: return (NIL); ! 111: switch (p->class) { ! 112: case VAR: ! 113: /* ! 114: * If a variable is ! 115: * qualified then get ! 116: * the rvalue by a ! 117: * lvalue and an ind. ! 118: */ ! 119: if (r[3] != NIL) ! 120: goto ind; ! 121: q = p->type; ! 122: if (q == NIL) ! 123: return (NIL); ! 124: # ifdef OBJ ! 125: w = width(q); ! 126: switch (w) { ! 127: case 8: ! 128: put(2, O_RV8 | bn << 8+INDX, p->value[0]); ! 129: break; ! 130: case 4: ! 131: put(2, O_RV4 | bn << 8+INDX, p->value[0]); ! 132: break; ! 133: case 2: ! 134: put(2, O_RV2 | bn << 8+INDX, p->value[0]); ! 135: break; ! 136: case 1: ! 137: put(2, O_RV1 | bn << 8+INDX, p->value[0]); ! 138: break; ! 139: default: ! 140: put(3, O_RV | bn << 8+INDX, p->value[0], w); ! 141: } ! 142: # endif OBJ ! 143: # ifdef PC ! 144: if ( required == RREQ ) { ! 145: putRV( p -> symbol , bn , p -> value[0] ! 146: , p2type( q ) ); ! 147: } else { ! 148: putLV( p -> symbol , bn , p -> value[0] ! 149: , p2type( q ) ); ! 150: } ! 151: # endif PC ! 152: return (q); ! 153: ! 154: case WITHPTR: ! 155: case REF: ! 156: /* ! 157: * A lvalue for these ! 158: * is actually what one ! 159: * might consider a rvalue. ! 160: */ ! 161: ind: ! 162: q = lvalue(r, NOFLAGS , LREQ ); ! 163: if (q == NIL) ! 164: return (NIL); ! 165: # ifdef OBJ ! 166: w = width(q); ! 167: switch (w) { ! 168: case 8: ! 169: put(1, O_IND8); ! 170: break; ! 171: case 4: ! 172: put(1, O_IND4); ! 173: break; ! 174: case 2: ! 175: put(1, O_IND2); ! 176: break; ! 177: case 1: ! 178: put(1, O_IND1); ! 179: break; ! 180: default: ! 181: put(2, O_IND, w); ! 182: } ! 183: # endif OBJ ! 184: # ifdef PC ! 185: if ( required == RREQ ) { ! 186: putop( P2UNARY P2MUL , p2type( q ) ); ! 187: } ! 188: # endif PC ! 189: return (q); ! 190: ! 191: case CONST: ! 192: if (r[3] != NIL) { ! 193: error("%s is a constant and cannot be qualified", r[2]); ! 194: return (NIL); ! 195: } ! 196: q = p->type; ! 197: if (q == NIL) ! 198: return (NIL); ! 199: if (q == nl+TSTR) { ! 200: /* ! 201: * Find the size of the string ! 202: * constant if needed. ! 203: */ ! 204: cp = p->ptr[0]; ! 205: cstrng: ! 206: cp1 = cp; ! 207: for (c = 0; *cp++; c++) ! 208: continue; ! 209: if (contype != NIL && !opt('s')) { ! 210: if (width(contype) < c && classify(contype) == TSTR) { ! 211: error("Constant string too long"); ! 212: return (NIL); ! 213: } ! 214: c = width(contype); ! 215: } ! 216: # ifdef OBJ ! 217: put( 2 + (sizeof(char *)/sizeof(short)) ! 218: , O_CONG, c, cp1); ! 219: # endif OBJ ! 220: # ifdef PC ! 221: putCONG( cp1 , c , required ); ! 222: # endif PC ! 223: /* ! 224: * Define the string temporarily ! 225: * so later people can know its ! 226: * width. ! 227: * cleaned out by stat. ! 228: */ ! 229: q = defnl(0, STR, 0, c); ! 230: q->type = q; ! 231: return (q); ! 232: } ! 233: if (q == nl+T1CHAR) { ! 234: # ifdef OBJ ! 235: put(2, O_CONC, p->value[0]); ! 236: # endif OBJ ! 237: # ifdef PC ! 238: putleaf( P2ICON , p -> value[0] , 0 ! 239: , P2CHAR , 0 ); ! 240: # endif PC ! 241: return (q); ! 242: } ! 243: /* ! 244: * Every other kind of constant here ! 245: */ ! 246: switch (width(q)) { ! 247: case 8: ! 248: #ifndef DEBUG ! 249: # ifdef OBJ ! 250: put(2, O_CON8, p->real); ! 251: # endif OBJ ! 252: # ifdef PC ! 253: putCON8( p -> real ); ! 254: # endif PC ! 255: #else ! 256: if (hp21mx) { ! 257: f = p->real; ! 258: conv(&f); ! 259: l = f.plong; ! 260: put(2, O_CON4, l); ! 261: } else ! 262: # ifdef OBJ ! 263: put(2, O_CON8, p->real); ! 264: # endif OBJ ! 265: # ifdef PC ! 266: putCON8( p -> real ); ! 267: # endif PC ! 268: #endif ! 269: break; ! 270: case 4: ! 271: # ifdef OBJ ! 272: put(2, O_CON4, p->range[0]); ! 273: # endif OBJ ! 274: # ifdef PC ! 275: putleaf( P2ICON , p -> range[0] , 0 ! 276: , P2INT , 0 ); ! 277: # endif PC ! 278: break; ! 279: case 2: ! 280: # ifdef OBJ ! 281: put(2, O_CON2, ( short ) p->range[0]); ! 282: # endif OBJ ! 283: # ifdef PC ! 284: /* ! 285: * make short constants ints ! 286: */ ! 287: putleaf( P2ICON , (short) p -> range[0] ! 288: , 0 , P2INT , 0 ); ! 289: # endif PC ! 290: break; ! 291: case 1: ! 292: # ifdef OBJ ! 293: put(2, O_CON1, p->value[0]); ! 294: # endif OBJ ! 295: # ifdef PC ! 296: /* ! 297: * make char constants ints ! 298: */ ! 299: putleaf( P2ICON , p -> value[0] , 0 ! 300: , P2INT , 0 ); ! 301: # endif PC ! 302: break; ! 303: default: ! 304: panic("rval"); ! 305: } ! 306: return (q); ! 307: ! 308: case FUNC: ! 309: case FFUNC: ! 310: /* ! 311: * Function call with no arguments. ! 312: */ ! 313: if (r[3]) { ! 314: error("Can't qualify a function result value"); ! 315: return (NIL); ! 316: } ! 317: # ifdef OBJ ! 318: return (funccod((int *) r)); ! 319: # endif OBJ ! 320: # ifdef PC ! 321: return (pcfunccod( r )); ! 322: # endif PC ! 323: ! 324: case TYPE: ! 325: error("Type names (e.g. %s) allowed only in declarations", p->symbol); ! 326: return (NIL); ! 327: ! 328: case PROC: ! 329: case FPROC: ! 330: error("Procedure %s found where expression required", p->symbol); ! 331: return (NIL); ! 332: default: ! 333: panic("rvid"); ! 334: } ! 335: /* ! 336: * Constant sets ! 337: */ ! 338: case T_CSET: ! 339: # ifdef OBJ ! 340: if ( precset( r , contype , &csetd ) ) { ! 341: if ( csetd.csettype == NIL ) { ! 342: return NIL; ! 343: } ! 344: postcset( r , &csetd ); ! 345: } else { ! 346: put( 2, O_PUSH, -width(csetd.csettype)); ! 347: postcset( r , &csetd ); ! 348: setran( ( csetd.csettype ) -> type ); ! 349: put( 2, O_CON24, set.uprbp); ! 350: put( 2, O_CON24, set.lwrb); ! 351: put( 2, O_CTTOT, 5 + csetd.singcnt + 2 * csetd.paircnt); ! 352: } ! 353: return csetd.csettype; ! 354: # endif OBJ ! 355: # ifdef PC ! 356: if ( precset( r , contype , &csetd ) ) { ! 357: if ( csetd.csettype == NIL ) { ! 358: return NIL; ! 359: } ! 360: postcset( r , &csetd ); ! 361: } else { ! 362: putleaf( P2ICON , 0 , 0 ! 363: , ADDTYPE( P2FTN | P2INT , P2PTR ) ! 364: , "_CTTOT" ); ! 365: /* ! 366: * allocate a temporary and use it ! 367: */ ! 368: sizes[ cbn ].om_off -= lwidth( csetd.csettype ); ! 369: tempoff = sizes[ cbn ].om_off; ! 370: putlbracket( ftnno , -tempoff ); ! 371: if ( tempoff < sizes[ cbn ].om_max ) { ! 372: sizes[ cbn ].om_max = tempoff; ! 373: } ! 374: putLV( 0 , cbn , tempoff , P2PTR|P2STRTY ); ! 375: setran( ( csetd.csettype ) -> type ); ! 376: putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 ); ! 377: putop( P2LISTOP , P2INT ); ! 378: putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 ); ! 379: putop( P2LISTOP , P2INT ); ! 380: postcset( r , &csetd ); ! 381: putop( P2CALL , P2INT ); ! 382: } ! 383: return csetd.csettype; ! 384: # endif PC ! 385: ! 386: /* ! 387: * Unary plus and minus ! 388: */ ! 389: case T_PLUS: ! 390: case T_MINUS: ! 391: q = rvalue(r[2], NIL , RREQ ); ! 392: if (q == NIL) ! 393: return (NIL); ! 394: if (isnta(q, "id")) { ! 395: error("Operand of %s must be integer or real, not %s", opname, nameof(q)); ! 396: return (NIL); ! 397: } ! 398: if (r[0] == T_MINUS) { ! 399: # ifdef OBJ ! 400: put(1, O_NEG2 + (width(q) >> 2)); ! 401: # endif OBJ ! 402: # ifdef PC ! 403: putop( P2UNARY P2MINUS , p2type( q ) ); ! 404: # endif PC ! 405: return (isa(q, "d") ? q : nl+T4INT); ! 406: } ! 407: return (q); ! 408: ! 409: case T_NOT: ! 410: q = rvalue(r[2], NIL , RREQ ); ! 411: if (q == NIL) ! 412: return (NIL); ! 413: if (isnta(q, "b")) { ! 414: error("not must operate on a Boolean, not %s", nameof(q)); ! 415: return (NIL); ! 416: } ! 417: # ifdef OBJ ! 418: put(1, O_NOT); ! 419: # endif OBJ ! 420: # ifdef PC ! 421: putop( P2NOT , P2INT ); ! 422: # endif PC ! 423: return (nl+T1BOOL); ! 424: ! 425: case T_AND: ! 426: case T_OR: ! 427: p = rvalue(r[2], NIL , RREQ ); ! 428: p1 = rvalue(r[3], NIL , RREQ ); ! 429: if (p == NIL || p1 == NIL) ! 430: return (NIL); ! 431: if (isnta(p, "b")) { ! 432: error("Left operand of %s must be Boolean, not %s", opname, nameof(p)); ! 433: return (NIL); ! 434: } ! 435: if (isnta(p1, "b")) { ! 436: error("Right operand of %s must be Boolean, not %s", opname, nameof(p1)); ! 437: return (NIL); ! 438: } ! 439: # ifdef OBJ ! 440: put(1, r[0] == T_AND ? O_AND : O_OR); ! 441: # endif OBJ ! 442: # ifdef PC ! 443: /* ! 444: * note the use of & and | rather than && and || ! 445: * to force evaluation of all the expressions. ! 446: */ ! 447: putop( r[ 0 ] == T_AND ? P2AND : P2OR , P2INT ); ! 448: # endif PC ! 449: return (nl+T1BOOL); ! 450: ! 451: case T_DIVD: ! 452: # ifdef OBJ ! 453: p = rvalue(r[2], NIL , RREQ ); ! 454: p1 = rvalue(r[3], NIL , RREQ ); ! 455: # endif OBJ ! 456: # ifdef PC ! 457: /* ! 458: * force these to be doubles for the divide ! 459: */ ! 460: p = rvalue( r[ 2 ] , NIL , RREQ ); ! 461: if ( isnta( p , "d" ) ) { ! 462: putop( P2SCONV , P2DOUBLE ); ! 463: } ! 464: p1 = rvalue( r[ 3 ] , NIL , RREQ ); ! 465: if ( isnta( p1 , "d" ) ) { ! 466: putop( P2SCONV , P2DOUBLE ); ! 467: } ! 468: # endif PC ! 469: if (p == NIL || p1 == NIL) ! 470: return (NIL); ! 471: if (isnta(p, "id")) { ! 472: error("Left operand of / must be integer or real, not %s", nameof(p)); ! 473: return (NIL); ! 474: } ! 475: if (isnta(p1, "id")) { ! 476: error("Right operand of / must be integer or real, not %s", nameof(p1)); ! 477: return (NIL); ! 478: } ! 479: # ifdef OBJ ! 480: return gen(NIL, r[0], width(p), width(p1)); ! 481: # endif OBJ ! 482: # ifdef PC ! 483: putop( P2DIV , P2DOUBLE ); ! 484: return nl + TDOUBLE; ! 485: # endif PC ! 486: ! 487: case T_MULT: ! 488: case T_ADD: ! 489: case T_SUB: ! 490: # ifdef OBJ ! 491: /* ! 492: * If the context hasn't told us the type ! 493: * and a constant set is present ! 494: * we need to infer the type ! 495: * before generating code. ! 496: */ ! 497: if ( contype == NIL ) { ! 498: codeoff(); ! 499: contype = rvalue( r[3] , NIL , RREQ ); ! 500: codeon(); ! 501: if ( contype == lookup( intset ) -> type ) { ! 502: codeoff(); ! 503: contype = rvalue( r[2] , NIL , RREQ ); ! 504: codeon(); ! 505: } ! 506: } ! 507: if ( contype == NIL ) { ! 508: return NIL; ! 509: } ! 510: p = rvalue( r[2] , contype , RREQ ); ! 511: p1 = rvalue( r[3] , p , RREQ ); ! 512: if ( p == NIL || p1 == NIL ) ! 513: return NIL; ! 514: if (isa(p, "id") && isa(p1, "id")) ! 515: return (gen(NIL, r[0], width(p), width(p1))); ! 516: if (isa(p, "t") && isa(p1, "t")) { ! 517: if (p != p1) { ! 518: error("Set types of operands of %s must be identical", opname); ! 519: return (NIL); ! 520: } ! 521: gen(TSET, r[0], width(p), 0); ! 522: return (p); ! 523: } ! 524: # endif OBJ ! 525: # ifdef PC ! 526: /* ! 527: * the second pass can't do ! 528: * long op double or double op long ! 529: * so we have to know the type of both operands ! 530: * also, it gets tricky for sets, which are done ! 531: * by function calls. ! 532: */ ! 533: codeoff(); ! 534: p1 = rvalue( r[ 3 ] , contype , RREQ ); ! 535: codeon(); ! 536: if ( isa( p1 , "id" ) ) { ! 537: p = rvalue( r[ 2 ] , contype , RREQ ); ! 538: if ( ( p == NIL ) || ( p1 == NIL ) ) { ! 539: return NIL; ! 540: } ! 541: if ( isa( p , "i" ) && isa( p1 , "d" ) ) { ! 542: putop( P2SCONV , P2DOUBLE ); ! 543: } ! 544: p1 = rvalue( r[ 3 ] , contype , RREQ ); ! 545: if ( isa( p , "d" ) && isa( p1 , "i" ) ) { ! 546: putop( P2SCONV , P2DOUBLE ); ! 547: } ! 548: if ( isa( p , "id" ) ) { ! 549: if ( isa( p , "d" ) || isa( p1 , "d" ) ) { ! 550: ctype = P2DOUBLE; ! 551: rettype = nl + TDOUBLE; ! 552: } else { ! 553: ctype = P2INT; ! 554: rettype = nl + T4INT; ! 555: } ! 556: putop( mathop[ r[0] - T_MULT ] , ctype ); ! 557: return rettype; ! 558: } ! 559: } ! 560: if ( isa( p1 , "t" ) ) { ! 561: putleaf( P2ICON , 0 , 0 ! 562: , ADDTYPE( ADDTYPE( P2PTR | P2STRTY , P2FTN ) ! 563: , P2PTR ) ! 564: , setop[ r[0] - T_MULT ] ); ! 565: if ( contype == NIL ) { ! 566: contype = p1; ! 567: if ( contype == lookup( intset ) -> type ) { ! 568: codeoff(); ! 569: contype = rvalue( r[2] , NIL , LREQ ); ! 570: codeon(); ! 571: } ! 572: } ! 573: if ( contype == NIL ) { ! 574: return NIL; ! 575: } ! 576: /* ! 577: * allocate a temporary and use it ! 578: */ ! 579: sizes[ cbn ].om_off -= lwidth( contype ); ! 580: tempoff = sizes[ cbn ].om_off; ! 581: putlbracket( ftnno , -tempoff ); ! 582: if ( tempoff < sizes[ cbn ].om_max ) { ! 583: sizes[ cbn ].om_max = tempoff; ! 584: } ! 585: putLV( 0 , cbn , tempoff , P2PTR|P2STRTY ); ! 586: p = rvalue( r[2] , contype , LREQ ); ! 587: if ( isa( p , "t" ) ) { ! 588: putop( P2LISTOP , P2INT ); ! 589: if ( p == NIL || p1 == NIL ) { ! 590: return NIL; ! 591: } ! 592: p1 = rvalue( r[3] , p , LREQ ); ! 593: if ( p != p1 ) { ! 594: error("Set types of operands of %s must be identical", opname); ! 595: return NIL; ! 596: } ! 597: putop( P2LISTOP , P2INT ); ! 598: putleaf( P2ICON , lwidth( p1 ) / sizeof( long ) , 0 ! 599: , P2INT , 0 ); ! 600: putop( P2LISTOP , P2INT ); ! 601: putop( P2CALL , P2PTR | P2STRTY ); ! 602: return p; ! 603: } ! 604: } ! 605: if ( isnta( p1 , "idt" ) ) { ! 606: /* ! 607: * find type of left operand for error message. ! 608: */ ! 609: p = rvalue( r[2] , contype , RREQ ); ! 610: } ! 611: /* ! 612: * don't give spurious error messages. ! 613: */ ! 614: if ( p == NIL || p1 == NIL ) { ! 615: return NIL; ! 616: } ! 617: # endif PC ! 618: if (isnta(p, "idt")) { ! 619: error("Left operand of %s must be integer, real or set, not %s", opname, nameof(p)); ! 620: return (NIL); ! 621: } ! 622: if (isnta(p1, "idt")) { ! 623: error("Right operand of %s must be integer, real or set, not %s", opname, nameof(p1)); ! 624: return (NIL); ! 625: } ! 626: error("Cannot mix sets with integers and reals as operands of %s", opname); ! 627: return (NIL); ! 628: ! 629: case T_MOD: ! 630: case T_DIV: ! 631: p = rvalue(r[2], NIL , RREQ ); ! 632: p1 = rvalue(r[3], NIL , RREQ ); ! 633: if (p == NIL || p1 == NIL) ! 634: return (NIL); ! 635: if (isnta(p, "i")) { ! 636: error("Left operand of %s must be integer, not %s", opname, nameof(p)); ! 637: return (NIL); ! 638: } ! 639: if (isnta(p1, "i")) { ! 640: error("Right operand of %s must be integer, not %s", opname, nameof(p1)); ! 641: return (NIL); ! 642: } ! 643: # ifdef OBJ ! 644: return (gen(NIL, r[0], width(p), width(p1))); ! 645: # endif OBJ ! 646: # ifdef PC ! 647: putop( r[ 0 ] == T_DIV ? P2DIV : P2MOD , P2INT ); ! 648: return ( nl + T4INT ); ! 649: # endif PC ! 650: ! 651: case T_EQ: ! 652: case T_NE: ! 653: case T_LT: ! 654: case T_GT: ! 655: case T_LE: ! 656: case T_GE: ! 657: /* ! 658: * Since there can be no, a priori, knowledge ! 659: * of the context type should a constant string ! 660: * or set arise, we must poke around to find such ! 661: * a type if possible. Since constant strings can ! 662: * always masquerade as identifiers, this is always ! 663: * necessary. ! 664: */ ! 665: codeoff(); ! 666: p1 = rvalue(r[3], NIL , RREQ ); ! 667: codeon(); ! 668: if (p1 == NIL) ! 669: return (NIL); ! 670: contype = p1; ! 671: # ifdef OBJ ! 672: if (p1->class == STR) { ! 673: /* ! 674: * For constant strings we want ! 675: * the longest type so as to be ! 676: * able to do padding (more importantly ! 677: * avoiding truncation). For clarity, ! 678: * we get this length here. ! 679: */ ! 680: codeoff(); ! 681: p = rvalue(r[2], NIL , RREQ ); ! 682: codeon(); ! 683: if (p == NIL) ! 684: return (NIL); ! 685: if (width(p) > width(p1)) ! 686: contype = p; ! 687: } else if ( isa( p1 , "t" ) ) { ! 688: if ( contype == lookup( intset ) -> type ) { ! 689: codeoff(); ! 690: contype = rvalue( r[2] , NIL , RREQ ); ! 691: codeon(); ! 692: if ( contype == NIL ) { ! 693: return NIL; ! 694: } ! 695: } ! 696: } ! 697: /* ! 698: * Now we generate code for ! 699: * the operands of the relational ! 700: * operation. ! 701: */ ! 702: p = rvalue(r[2], contype , RREQ ); ! 703: if (p == NIL) ! 704: return (NIL); ! 705: p1 = rvalue(r[3], p , RREQ ); ! 706: if (p1 == NIL) ! 707: return (NIL); ! 708: # endif OBJ ! 709: # ifdef PC ! 710: c1 = classify( p1 ); ! 711: if ( c1 == TSET || c1 == TSTR || c1 == TREC ) { ! 712: putleaf( P2ICON , 0 , 0 ! 713: , ADDTYPE( P2FTN | P2INT , P2PTR ) ! 714: , c1 == TSET ? relts[ r[0] - T_EQ ] ! 715: : relss[ r[0] - T_EQ ] ); ! 716: /* ! 717: * for [] and strings, comparisons are done on ! 718: * the maximum width of the two sides. ! 719: * for other sets, we have to ask the left side ! 720: * what type it is based on the type of the right. ! 721: * (this matters for intsets). ! 722: */ ! 723: if ( c1 == TSTR ) { ! 724: codeoff(); ! 725: p = rvalue( r[ 2 ] , NIL , LREQ ); ! 726: codeon(); ! 727: if ( p == NIL ) { ! 728: return NIL; ! 729: } ! 730: if ( lwidth( p ) > lwidth( p1 ) ) { ! 731: contype = p; ! 732: } ! 733: } else if ( c1 == TSET ) { ! 734: if ( contype == lookup( intset ) -> type ) { ! 735: codeoff(); ! 736: p = rvalue( r[ 2 ] , NIL , LREQ ); ! 737: codeon(); ! 738: if ( p == NIL ) { ! 739: return NIL; ! 740: } ! 741: contype = p; ! 742: } ! 743: } ! 744: /* ! 745: * put out the width of the comparison. ! 746: */ ! 747: putleaf( P2ICON , lwidth( contype ) , 0 , P2INT , 0 ); ! 748: /* ! 749: * and the left hand side, ! 750: * for sets, strings, records ! 751: */ ! 752: p = rvalue( r[ 2 ] , contype , LREQ ); ! 753: putop( P2LISTOP , P2INT ); ! 754: p1 = rvalue( r[ 3 ] , p , LREQ ); ! 755: putop( P2LISTOP , P2INT ); ! 756: putop( P2CALL , P2INT ); ! 757: } else { ! 758: /* ! 759: * the easy (scalar or error) case ! 760: */ ! 761: p = rvalue( r[ 2 ] , contype , RREQ ); ! 762: if ( p == NIL ) { ! 763: return NIL; ! 764: /* ! 765: * since the second pass can't do ! 766: * long op double or double op long ! 767: * we may have to do some coercing. ! 768: */ ! 769: if ( isa( p , "i" ) && isa( p1 , "d" ) ) ! 770: putop( P2SCONV , P2DOUBLE ); ! 771: } ! 772: p1 = rvalue( r[ 3 ] , p , RREQ ); ! 773: if ( isa( p , "d" ) && isa( p1 , "i" ) ) ! 774: putop( P2SCONV , P2DOUBLE ); ! 775: putop( relops[ r[0] - T_EQ ] , P2INT ); ! 776: } ! 777: # endif PC ! 778: c = classify(p); ! 779: c1 = classify(p1); ! 780: if (nocomp(c) || nocomp(c1)) ! 781: return (NIL); ! 782: g = NIL; ! 783: switch (c) { ! 784: case TBOOL: ! 785: case TCHAR: ! 786: if (c != c1) ! 787: goto clash; ! 788: break; ! 789: case TINT: ! 790: case TDOUBLE: ! 791: if (c1 != TINT && c1 != TDOUBLE) ! 792: goto clash; ! 793: break; ! 794: case TSCAL: ! 795: if (c1 != TSCAL) ! 796: goto clash; ! 797: if (scalar(p) != scalar(p1)) ! 798: goto nonident; ! 799: break; ! 800: case TSET: ! 801: if (c1 != TSET) ! 802: goto clash; ! 803: if (p != p1) ! 804: goto nonident; ! 805: g = TSET; ! 806: break; ! 807: case TREC: ! 808: if ( c1 != TREC ) { ! 809: goto clash; ! 810: } ! 811: if ( p != p1 ) { ! 812: goto nonident; ! 813: } ! 814: if (r[0] != T_EQ && r[0] != T_NE) { ! 815: error("%s not allowed on records - only allow = and <>" , opname ); ! 816: return (NIL); ! 817: } ! 818: g = TREC; ! 819: break; ! 820: case TPTR: ! 821: case TNIL: ! 822: if (c1 != TPTR && c1 != TNIL) ! 823: goto clash; ! 824: if (r[0] != T_EQ && r[0] != T_NE) { ! 825: error("%s not allowed on pointers - only allow = and <>" , opname ); ! 826: return (NIL); ! 827: } ! 828: break; ! 829: case TSTR: ! 830: if (c1 != TSTR) ! 831: goto clash; ! 832: if (width(p) != width(p1)) { ! 833: error("Strings not same length in %s comparison", opname); ! 834: return (NIL); ! 835: } ! 836: g = TSTR; ! 837: break; ! 838: default: ! 839: panic("rval2"); ! 840: } ! 841: # ifdef OBJ ! 842: return (gen(g, r[0], width(p), width(p1))); ! 843: # endif OBJ ! 844: # ifdef PC ! 845: return nl + TBOOL; ! 846: # endif PC ! 847: clash: ! 848: error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname); ! 849: return (NIL); ! 850: nonident: ! 851: error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname); ! 852: return (NIL); ! 853: ! 854: case T_IN: ! 855: rt = r[3]; ! 856: # ifdef OBJ ! 857: if (rt != NIL && rt[0] == T_CSET) { ! 858: precset( rt , NIL , &csetd ); ! 859: p1 = csetd.csettype; ! 860: if (p1 == NIL) ! 861: return NIL; ! 862: postcset( rt, &csetd); ! 863: } else { ! 864: p1 = stkrval(r[3], NIL , RREQ ); ! 865: rt = NIL; ! 866: } ! 867: # endif OBJ ! 868: # ifdef PC ! 869: if (rt != NIL && rt[0] == T_CSET) { ! 870: if ( precset( rt , NIL , &csetd ) ) { ! 871: putleaf( P2ICON , 0 , 0 ! 872: , ADDTYPE( P2FTN | P2INT , P2PTR ) ! 873: , "_IN" ); ! 874: } else { ! 875: putleaf( P2ICON , 0 , 0 ! 876: , ADDTYPE( P2FTN | P2INT , P2PTR ) ! 877: , "_INCT" ); ! 878: } ! 879: p1 = csetd.csettype; ! 880: if (p1 == NIL) ! 881: return NIL; ! 882: } else { ! 883: putleaf( P2ICON , 0 , 0 ! 884: , ADDTYPE( P2FTN | P2INT , P2PTR ) ! 885: , "_IN" ); ! 886: codeoff(); ! 887: p1 = rvalue(r[3], NIL , LREQ ); ! 888: codeon(); ! 889: } ! 890: # endif PC ! 891: p = stkrval(r[2], NIL , RREQ ); ! 892: if (p == NIL || p1 == NIL) ! 893: return (NIL); ! 894: if (p1->class != SET) { ! 895: error("Right operand of 'in' must be a set, not %s", nameof(p1)); ! 896: return (NIL); ! 897: } ! 898: if (incompat(p, p1->type, r[2])) { ! 899: cerror("Index type clashed with set component type for 'in'"); ! 900: return (NIL); ! 901: } ! 902: setran(p1->type); ! 903: # ifdef OBJ ! 904: if (rt == NIL || csetd.comptime) ! 905: put(4, O_IN, width(p1), set.lwrb, set.uprbp); ! 906: else ! 907: put(2, O_INCT, 3 + csetd.singcnt + 2*csetd.paircnt); ! 908: # endif OBJ ! 909: # ifdef PC ! 910: if ( rt == NIL || rt[0] != T_CSET ) { ! 911: putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 ); ! 912: putop( P2LISTOP , P2INT ); ! 913: putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 ); ! 914: putop( P2LISTOP , P2INT ); ! 915: p1 = rvalue( r[3] , NIL , LREQ ); ! 916: putop( P2LISTOP , P2INT ); ! 917: } else if ( csetd.comptime ) { ! 918: putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 ); ! 919: putop( P2LISTOP , P2INT ); ! 920: putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 ); ! 921: putop( P2LISTOP , P2INT ); ! 922: postcset( r[3] , &csetd ); ! 923: putop( P2LISTOP , P2INT ); ! 924: } else { ! 925: postcset( r[3] , &csetd ); ! 926: } ! 927: putop( P2CALL , P2INT ); ! 928: # endif PC ! 929: return (nl+T1BOOL); ! 930: default: ! 931: if (r[2] == NIL) ! 932: return (NIL); ! 933: switch (r[0]) { ! 934: default: ! 935: panic("rval3"); ! 936: ! 937: ! 938: /* ! 939: * An octal number ! 940: */ ! 941: case T_BINT: ! 942: f = a8tol(r[2]); ! 943: goto conint; ! 944: ! 945: /* ! 946: * A decimal number ! 947: */ ! 948: case T_INT: ! 949: f = atof(r[2]); ! 950: conint: ! 951: if (f > MAXINT || f < MININT) { ! 952: error("Constant too large for this implementation"); ! 953: return (NIL); ! 954: } ! 955: l = f; ! 956: if (bytes(l, l) <= 2) { ! 957: # ifdef OBJ ! 958: put(2, O_CON2, ( short ) l); ! 959: # endif OBJ ! 960: # ifdef PC ! 961: /* ! 962: * short constants are ints ! 963: */ ! 964: putleaf( P2ICON , l , 0 , P2INT , 0 ); ! 965: # endif PC ! 966: return (nl+T2INT); ! 967: } ! 968: # ifdef OBJ ! 969: put(2, O_CON4, l); ! 970: # endif OBJ ! 971: # ifdef PC ! 972: putleaf( P2ICON , l , 0 , P2INT , 0 ); ! 973: # endif PC ! 974: return (nl+T4INT); ! 975: ! 976: /* ! 977: * A floating point number ! 978: */ ! 979: case T_FINT: ! 980: # ifdef OBJ ! 981: put(2, O_CON8, atof(r[2])); ! 982: # endif OBJ ! 983: # ifdef PC ! 984: putCON8( atof( r[2] ) ); ! 985: # endif PC ! 986: return (nl+TDOUBLE); ! 987: ! 988: /* ! 989: * Constant strings. Note that constant characters ! 990: * are constant strings of length one; there is ! 991: * no constant string of length one. ! 992: */ ! 993: case T_STRNG: ! 994: cp = r[2]; ! 995: if (cp[1] == 0) { ! 996: # ifdef OBJ ! 997: put(2, O_CONC, cp[0]); ! 998: # endif OBJ ! 999: # ifdef PC ! 1000: putleaf( P2ICON , cp[0] , 0 , P2CHAR , 0 ); ! 1001: # endif PC ! 1002: return (nl+T1CHAR); ! 1003: } ! 1004: goto cstrng; ! 1005: } ! 1006: ! 1007: } ! 1008: } ! 1009: ! 1010: /* ! 1011: * Can a class appear ! 1012: * in a comparison ? ! 1013: */ ! 1014: nocomp(c) ! 1015: int c; ! 1016: { ! 1017: ! 1018: switch (c) { ! 1019: case TREC: ! 1020: if ( line != reccompline ) { ! 1021: reccompline = line; ! 1022: warning(); ! 1023: if ( opt( 's' ) ) { ! 1024: standard(); ! 1025: } ! 1026: error("record comparison is non-standard"); ! 1027: } ! 1028: break; ! 1029: case TFILE: ! 1030: case TARY: ! 1031: error("%ss may not participate in comparisons", clnames[c]); ! 1032: return (1); ! 1033: } ! 1034: return (NIL); ! 1035: } ! 1036: ! 1037: /* ! 1038: * this is sort of like gconst, except it works on expression trees ! 1039: * rather than declaration trees, and doesn't give error messages for ! 1040: * non-constant things. ! 1041: * as a side effect this fills in the con structure that gconst uses. ! 1042: * this returns TRUE or FALSE. ! 1043: */ ! 1044: constval(r) ! 1045: register int *r; ! 1046: { ! 1047: register struct nl *np; ! 1048: register *cn; ! 1049: char *cp; ! 1050: int negd, sgnd; ! 1051: long ci; ! 1052: ! 1053: con.ctype = NIL; ! 1054: cn = r; ! 1055: negd = sgnd = 0; ! 1056: loop: ! 1057: /* ! 1058: * cn[2] is nil if error recovery generated a T_STRNG ! 1059: */ ! 1060: if (cn == NIL || cn[2] == NIL) ! 1061: return FALSE; ! 1062: switch (cn[0]) { ! 1063: default: ! 1064: return FALSE; ! 1065: case T_MINUS: ! 1066: negd = 1 - negd; ! 1067: /* and fall through */ ! 1068: case T_PLUS: ! 1069: sgnd++; ! 1070: cn = cn[2]; ! 1071: goto loop; ! 1072: case T_NIL: ! 1073: con.cpval = NIL; ! 1074: con.cival = 0; ! 1075: con.crval = con.cival; ! 1076: con.ctype = nl + TNIL; ! 1077: break; ! 1078: case T_VAR: ! 1079: np = lookup(cn[2]); ! 1080: if (np == NIL || np->class != CONST) { ! 1081: return FALSE; ! 1082: } ! 1083: if ( cn[3] != NIL ) { ! 1084: return FALSE; ! 1085: } ! 1086: con.ctype = np->type; ! 1087: switch (classify(np->type)) { ! 1088: case TINT: ! 1089: con.crval = np->range[0]; ! 1090: break; ! 1091: case TDOUBLE: ! 1092: con.crval = np->real; ! 1093: break; ! 1094: case TBOOL: ! 1095: case TCHAR: ! 1096: case TSCAL: ! 1097: con.cival = np->value[0]; ! 1098: con.crval = con.cival; ! 1099: break; ! 1100: case TSTR: ! 1101: con.cpval = np->ptr[0]; ! 1102: break; ! 1103: default: ! 1104: con.ctype = NIL; ! 1105: return FALSE; ! 1106: } ! 1107: break; ! 1108: case T_BINT: ! 1109: con.crval = a8tol(cn[2]); ! 1110: goto restcon; ! 1111: case T_INT: ! 1112: con.crval = atof(cn[2]); ! 1113: if (con.crval > MAXINT || con.crval < MININT) { ! 1114: derror("Constant too large for this implementation"); ! 1115: con.crval = 0; ! 1116: } ! 1117: restcon: ! 1118: ci = con.crval; ! 1119: #ifndef PI0 ! 1120: if (bytes(ci, ci) <= 2) ! 1121: con.ctype = nl+T2INT; ! 1122: else ! 1123: #endif ! 1124: con.ctype = nl+T4INT; ! 1125: break; ! 1126: case T_FINT: ! 1127: con.ctype = nl+TDOUBLE; ! 1128: con.crval = atof(cn[2]); ! 1129: break; ! 1130: case T_STRNG: ! 1131: cp = cn[2]; ! 1132: if (cp[1] == 0) { ! 1133: con.ctype = nl+T1CHAR; ! 1134: con.cival = cp[0]; ! 1135: con.crval = con.cival; ! 1136: break; ! 1137: } ! 1138: con.ctype = nl+TSTR; ! 1139: con.cpval = cp; ! 1140: break; ! 1141: } ! 1142: if (sgnd) { ! 1143: if (isnta(con.ctype, "id")) { ! 1144: derror("%s constants cannot be signed", nameof(con.ctype)); ! 1145: return FALSE; ! 1146: } else if (negd) ! 1147: con.crval = -con.crval; ! 1148: } ! 1149: return TRUE; ! 1150: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.