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