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