1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)rval.c 1.18 11/11/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 } 514 if ( contype == NIL ) { 515 return NIL; 516 } 517 p = rvalue( r[2] , contype , RREQ ); 518 p1 = rvalue( r[3] , p , RREQ ); 519 if ( p == NIL || p1 == NIL ) 520 return NIL; 521 if (isa(p, "id") && isa(p1, "id")) 522 return (gen(NIL, r[0], width(p), width(p1))); 523 if (isa(p, "t") && isa(p1, "t")) { 524 if (p != p1) { 525 error("Set types of operands of %s must be identical", opname); 526 return (NIL); 527 } 528 gen(TSET, r[0], width(p), 0); 529 return (p); 530 } 531 # endif OBJ 532 # ifdef PC 533 /* 534 * the second pass can't do 535 * long op double or double op long 536 * so we have to know the type of both operands 537 * also, it gets tricky for sets, which are done 538 * by function calls. 539 */ 540 codeoff(); 541 p1 = rvalue( r[ 3 ] , contype , RREQ ); 542 codeon(); 543 if ( isa( p1 , "id" ) ) { 544 p = rvalue( r[ 2 ] , contype , RREQ ); 545 if ( ( p == NIL ) || ( p1 == NIL ) ) { 546 return NIL; 547 } 548 tuac(p, p1, &rettype, &ctype); 549 p1 = rvalue( r[ 3 ] , contype , RREQ ); 550 tuac(p1, p, &rettype, &ctype); 551 if ( isa( p , "id" ) ) { 552 putop( mathop[ r[0] - T_MULT ] , ctype ); 553 return rettype; 554 } 555 } 556 if ( isa( p1 , "t" ) ) { 557 putleaf( P2ICON , 0 , 0 558 , ADDTYPE( ADDTYPE( P2PTR | P2STRTY , P2FTN ) 559 , P2PTR ) 560 , setop[ r[0] - T_MULT ] ); 561 if ( contype == NIL ) { 562 codeoff(); 563 contype = rvalue( r[2] , p1 , LREQ ); 564 codeon(); 565 } 566 if ( contype == NIL ) { 567 return NIL; 568 } 569 /* 570 * allocate a temporary and use it 571 */ 572 tempnlp = tmpalloc(lwidth(contype), contype, NOREG); 573 putLV( 0 , cbn , tempnlp -> value[ NL_OFFS ] , 574 tempnlp -> extra_flags , P2PTR|P2STRTY ); 575 p = rvalue( r[2] , contype , LREQ ); 576 if ( isa( p , "t" ) ) { 577 putop( P2LISTOP , P2INT ); 578 if ( p == NIL || p1 == NIL ) { 579 return NIL; 580 } 581 p1 = rvalue( r[3] , p , LREQ ); 582 if ( p != p1 ) { 583 error("Set types of operands of %s must be identical", opname); 584 return NIL; 585 } 586 putop( P2LISTOP , P2INT ); 587 putleaf( P2ICON , lwidth( p1 ) / sizeof( long ) , 0 588 , P2INT , 0 ); 589 putop( P2LISTOP , P2INT ); 590 putop( P2CALL , P2PTR | P2STRTY ); 591 return p; 592 } 593 } 594 if ( isnta( p1 , "idt" ) ) { 595 /* 596 * find type of left operand for error message. 597 */ 598 p = rvalue( r[2] , contype , RREQ ); 599 } 600 /* 601 * don't give spurious error messages. 602 */ 603 if ( p == NIL || p1 == NIL ) { 604 return NIL; 605 } 606 # endif PC 607 if (isnta(p, "idt")) { 608 error("Left operand of %s must be integer, real or set, not %s", opname, nameof(p)); 609 return (NIL); 610 } 611 if (isnta(p1, "idt")) { 612 error("Right operand of %s must be integer, real or set, not %s", opname, nameof(p1)); 613 return (NIL); 614 } 615 error("Cannot mix sets with integers and reals as operands of %s", opname); 616 return (NIL); 617 618 case T_MOD: 619 case T_DIV: 620 p = rvalue(r[2], NIL , RREQ ); 621 # ifdef PC 622 sconv(p2type(p), P2INT); 623 # endif PC 624 p1 = rvalue(r[3], NIL , RREQ ); 625 # ifdef PC 626 sconv(p2type(p1), P2INT); 627 # endif PC 628 if (p == NIL || p1 == NIL) 629 return (NIL); 630 if (isnta(p, "i")) { 631 error("Left operand of %s must be integer, not %s", opname, nameof(p)); 632 return (NIL); 633 } 634 if (isnta(p1, "i")) { 635 error("Right operand of %s must be integer, not %s", opname, nameof(p1)); 636 return (NIL); 637 } 638 # ifdef OBJ 639 return (gen(NIL, r[0], width(p), width(p1))); 640 # endif OBJ 641 # ifdef PC 642 putop( r[ 0 ] == T_DIV ? P2DIV : P2MOD , P2INT ); 643 return ( nl + T4INT ); 644 # endif PC 645 646 case T_EQ: 647 case T_NE: 648 case T_LT: 649 case T_GT: 650 case T_LE: 651 case T_GE: 652 /* 653 * Since there can be no, a priori, knowledge 654 * of the context type should a constant string 655 * or set arise, we must poke around to find such 656 * a type if possible. Since constant strings can 657 * always masquerade as identifiers, this is always 658 * necessary. 659 */ 660 codeoff(); 661 p1 = rvalue(r[3], NIL , RREQ ); 662 codeon(); 663 if (p1 == NIL) 664 return (NIL); 665 contype = p1; 666 # ifdef OBJ 667 if (p1->class == STR) { 668 /* 669 * For constant strings we want 670 * the longest type so as to be 671 * able to do padding (more importantly 672 * avoiding truncation). For clarity, 673 * we get this length here. 674 */ 675 codeoff(); 676 p = rvalue(r[2], NIL , RREQ ); 677 codeon(); 678 if (p == NIL) 679 return (NIL); 680 if (width(p) > width(p1)) 681 contype = p; 682 } 683 /* 684 * Now we generate code for 685 * the operands of the relational 686 * operation. 687 */ 688 p = rvalue(r[2], contype , RREQ ); 689 if (p == NIL) 690 return (NIL); 691 p1 = rvalue(r[3], p , RREQ ); 692 if (p1 == NIL) 693 return (NIL); 694 # endif OBJ 695 # ifdef PC 696 c1 = classify( p1 ); 697 if ( c1 == TSET || c1 == TSTR || c1 == TREC ) { 698 putleaf( P2ICON , 0 , 0 699 , ADDTYPE( P2FTN | P2INT , P2PTR ) 700 , c1 == TSET ? relts[ r[0] - T_EQ ] 701 : relss[ r[0] - T_EQ ] ); 702 /* 703 * for [] and strings, comparisons are done on 704 * the maximum width of the two sides. 705 * for other sets, we have to ask the left side 706 * what type it is based on the type of the right. 707 * (this matters for intsets). 708 */ 709 if ( c1 == TSTR ) { 710 codeoff(); 711 p = rvalue( r[ 2 ] , NIL , LREQ ); 712 codeon(); 713 if ( p == NIL ) { 714 return NIL; 715 } 716 if ( lwidth( p ) > lwidth( p1 ) ) { 717 contype = p; 718 } 719 } else if ( c1 == TSET ) { 720 codeoff(); 721 p = rvalue( r[ 2 ] , contype , LREQ ); 722 codeon(); 723 if ( p == NIL ) { 724 return NIL; 725 } 726 contype = p; 727 } 728 /* 729 * put out the width of the comparison. 730 */ 731 putleaf( P2ICON , lwidth( contype ) , 0 , P2INT , 0 ); 732 /* 733 * and the left hand side, 734 * for sets, strings, records 735 */ 736 p = rvalue( r[ 2 ] , contype , LREQ ); 737 if ( p == NIL ) { 738 return NIL; 739 } 740 putop( P2LISTOP , P2INT ); 741 p1 = rvalue( r[ 3 ] , p , LREQ ); 742 if ( p1 == NIL ) { 743 return NIL; 744 } 745 putop( P2LISTOP , P2INT ); 746 putop( P2CALL , P2INT ); 747 } else { 748 /* 749 * the easy (scalar or error) case 750 */ 751 p = rvalue( r[ 2 ] , contype , RREQ ); 752 if ( p == NIL ) { 753 return NIL; 754 } 755 /* 756 * since the second pass can't do 757 * long op double or double op long 758 * we may have to do some coercing. 759 */ 760 tuac(p, p1, &rettype, &ctype); 761 p1 = rvalue( r[ 3 ] , p , RREQ ); 762 if ( p1 == NIL ) { 763 return NIL; 764 } 765 tuac(p1, p, &rettype, &ctype); 766 putop( relops[ r[0] - T_EQ ] , P2INT ); 767 sconv(P2INT, P2CHAR); 768 } 769 # endif PC 770 c = classify(p); 771 c1 = classify(p1); 772 if (nocomp(c) || nocomp(c1)) 773 return (NIL); 774 g = NIL; 775 switch (c) { 776 case TBOOL: 777 case TCHAR: 778 if (c != c1) 779 goto clash; 780 break; 781 case TINT: 782 case TDOUBLE: 783 if (c1 != TINT && c1 != TDOUBLE) 784 goto clash; 785 break; 786 case TSCAL: 787 if (c1 != TSCAL) 788 goto clash; 789 if (scalar(p) != scalar(p1)) 790 goto nonident; 791 break; 792 case TSET: 793 if (c1 != TSET) 794 goto clash; 795 if ( opt( 's' ) && 796 ( ( r[0] == T_LT ) || ( r[0] == T_GT ) ) && 797 ( line != nssetline ) ) { 798 nssetline = line; 799 standard(); 800 error("%s comparison on sets is non-standard" , opname ); 801 } 802 if (p != p1) 803 goto nonident; 804 g = TSET; 805 break; 806 case TREC: 807 if ( c1 != TREC ) { 808 goto clash; 809 } 810 if ( p != p1 ) { 811 goto nonident; 812 } 813 if (r[0] != T_EQ && r[0] != T_NE) { 814 error("%s not allowed on records - only allow = and <>" , opname ); 815 return (NIL); 816 } 817 g = TREC; 818 break; 819 case TPTR: 820 case TNIL: 821 if (c1 != TPTR && c1 != TNIL) 822 goto clash; 823 if (r[0] != T_EQ && r[0] != T_NE) { 824 error("%s not allowed on pointers - only allow = and <>" , opname ); 825 return (NIL); 826 } 827 if (p != nl+TNIL && p1 != nl+TNIL && p != p1) 828 goto nonident; 829 break; 830 case TSTR: 831 if (c1 != TSTR) 832 goto clash; 833 if (width(p) != width(p1)) { 834 error("Strings not same length in %s comparison", opname); 835 return (NIL); 836 } 837 g = TSTR; 838 break; 839 default: 840 panic("rval2"); 841 } 842 # ifdef OBJ 843 return (gen(g, r[0], width(p), width(p1))); 844 # endif OBJ 845 # ifdef PC 846 return nl + TBOOL; 847 # endif PC 848 clash: 849 error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname); 850 return (NIL); 851 nonident: 852 error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname); 853 return (NIL); 854 855 case T_IN: 856 rt = r[3]; 857 # ifdef OBJ 858 if (rt != NIL && rt[0] == T_CSET) { 859 precset( rt , NIL , &csetd ); 860 p1 = csetd.csettype; 861 if (p1 == NIL) 862 return NIL; 863 postcset( rt, &csetd); 864 } else { 865 p1 = stkrval(r[3], NIL , RREQ ); 866 rt = NIL; 867 } 868 # endif OBJ 869 # ifdef PC 870 if (rt != NIL && rt[0] == T_CSET) { 871 if ( precset( rt , NIL , &csetd ) ) { 872 putleaf( P2ICON , 0 , 0 873 , ADDTYPE( P2FTN | P2INT , P2PTR ) 874 , "_IN" ); 875 } else { 876 putleaf( P2ICON , 0 , 0 877 , ADDTYPE( P2FTN | P2INT , P2PTR ) 878 , "_INCT" ); 879 } 880 p1 = csetd.csettype; 881 if (p1 == NIL) 882 return NIL; 883 } else { 884 putleaf( P2ICON , 0 , 0 885 , ADDTYPE( P2FTN | P2INT , P2PTR ) 886 , "_IN" ); 887 codeoff(); 888 p1 = rvalue(r[3], NIL , LREQ ); 889 codeon(); 890 } 891 # endif PC 892 p = stkrval(r[2], NIL , RREQ ); 893 if (p == NIL || p1 == NIL) 894 return (NIL); 895 if (p1->class != SET) { 896 error("Right operand of 'in' must be a set, not %s", nameof(p1)); 897 return (NIL); 898 } 899 if (incompat(p, p1->type, r[2])) { 900 cerror("Index type clashed with set component type for 'in'"); 901 return (NIL); 902 } 903 setran(p1->type); 904 # ifdef OBJ 905 if (rt == NIL || csetd.comptime) 906 put(4, O_IN, width(p1), set.lwrb, set.uprbp); 907 else 908 put(2, O_INCT, 909 (int)(3 + csetd.singcnt + 2*csetd.paircnt)); 910 # endif OBJ 911 # ifdef PC 912 if ( rt == NIL || rt[0] != T_CSET ) { 913 putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 ); 914 putop( P2LISTOP , P2INT ); 915 putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 ); 916 putop( P2LISTOP , P2INT ); 917 p1 = rvalue( r[3] , NIL , LREQ ); 918 if ( p1 == NIL ) { 919 return NIL; 920 } 921 putop( P2LISTOP , P2INT ); 922 } else if ( csetd.comptime ) { 923 putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 ); 924 putop( P2LISTOP , P2INT ); 925 putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 ); 926 putop( P2LISTOP , P2INT ); 927 postcset( r[3] , &csetd ); 928 putop( P2LISTOP , P2INT ); 929 } else { 930 postcset( r[3] , &csetd ); 931 } 932 putop( P2CALL , P2INT ); 933 sconv(P2INT, P2CHAR); 934 # endif PC 935 return (nl+T1BOOL); 936 default: 937 if (r[2] == NIL) 938 return (NIL); 939 switch (r[0]) { 940 default: 941 panic("rval3"); 942 943 944 /* 945 * An octal number 946 */ 947 case T_BINT: 948 f = a8tol(r[2]); 949 goto conint; 950 951 /* 952 * A decimal number 953 */ 954 case T_INT: 955 f = atof(r[2]); 956 conint: 957 if (f > MAXINT || f < MININT) { 958 error("Constant too large for this implementation"); 959 return (NIL); 960 } 961 l = f; 962 # ifdef OBJ 963 if (bytes(l, l) <= 2) { 964 put(2, O_CON2, ( short ) l); 965 return (nl+T2INT); 966 } 967 put(2, O_CON4, l); 968 return (nl+T4INT); 969 # endif OBJ 970 # ifdef PC 971 switch (bytes(l, l)) { 972 case 1: 973 putleaf(P2ICON, l, 0, P2CHAR, 0); 974 return nl+T1INT; 975 case 2: 976 putleaf(P2ICON, l, 0, P2SHORT, 0); 977 return nl+T2INT; 978 case 4: 979 putleaf(P2ICON, l, 0, P2INT, 0); 980 return nl+T4INT; 981 } 982 # endif PC 983 984 /* 985 * A floating point number 986 */ 987 case T_FINT: 988 # ifdef OBJ 989 put(2, O_CON8, atof(r[2])); 990 # endif OBJ 991 # ifdef PC 992 putCON8( atof( r[2] ) ); 993 # endif PC 994 return (nl+TDOUBLE); 995 996 /* 997 * Constant strings. Note that constant characters 998 * are constant strings of length one; there is 999 * no constant string of length one. 1000 */ 1001 case T_STRNG: 1002 cp = r[2]; 1003 if (cp[1] == 0) { 1004 # ifdef OBJ 1005 put(2, O_CONC, cp[0]); 1006 # endif OBJ 1007 # ifdef PC 1008 putleaf( P2ICON , cp[0] , 0 , P2CHAR , 0 ); 1009 # endif PC 1010 return (nl+T1CHAR); 1011 } 1012 goto cstrng; 1013 } 1014 1015 } 1016 } 1017 1018 /* 1019 * Can a class appear 1020 * in a comparison ? 1021 */ 1022 nocomp(c) 1023 int c; 1024 { 1025 1026 switch (c) { 1027 case TREC: 1028 if ( line != reccompline ) { 1029 reccompline = line; 1030 warning(); 1031 if ( opt( 's' ) ) { 1032 standard(); 1033 } 1034 error("record comparison is non-standard"); 1035 } 1036 break; 1037 case TFILE: 1038 case TARY: 1039 error("%ss may not participate in comparisons", clnames[c]); 1040 return (1); 1041 } 1042 return (NIL); 1043 } 1044 1045 /* 1046 * this is sort of like gconst, except it works on expression trees 1047 * rather than declaration trees, and doesn't give error messages for 1048 * non-constant things. 1049 * as a side effect this fills in the con structure that gconst uses. 1050 * this returns TRUE or FALSE. 1051 */ 1052 constval(r) 1053 register int *r; 1054 { 1055 register struct nl *np; 1056 register *cn; 1057 char *cp; 1058 int negd, sgnd; 1059 long ci; 1060 1061 con.ctype = NIL; 1062 cn = r; 1063 negd = sgnd = 0; 1064 loop: 1065 /* 1066 * cn[2] is nil if error recovery generated a T_STRNG 1067 */ 1068 if (cn == NIL || cn[2] == NIL) 1069 return FALSE; 1070 switch (cn[0]) { 1071 default: 1072 return FALSE; 1073 case T_MINUS: 1074 negd = 1 - negd; 1075 /* and fall through */ 1076 case T_PLUS: 1077 sgnd++; 1078 cn = cn[2]; 1079 goto loop; 1080 case T_NIL: 1081 con.cpval = NIL; 1082 con.cival = 0; 1083 con.crval = con.cival; 1084 con.ctype = nl + TNIL; 1085 break; 1086 case T_VAR: 1087 np = lookup(cn[2]); 1088 if (np == NIL || np->class != CONST) { 1089 return FALSE; 1090 } 1091 if ( cn[3] != NIL ) { 1092 return FALSE; 1093 } 1094 con.ctype = np->type; 1095 switch (classify(np->type)) { 1096 case TINT: 1097 con.crval = np->range[0]; 1098 break; 1099 case TDOUBLE: 1100 con.crval = np->real; 1101 break; 1102 case TBOOL: 1103 case TCHAR: 1104 case TSCAL: 1105 con.cival = np->value[0]; 1106 con.crval = con.cival; 1107 break; 1108 case TSTR: 1109 con.cpval = np->ptr[0]; 1110 break; 1111 default: 1112 con.ctype = NIL; 1113 return FALSE; 1114 } 1115 break; 1116 case T_BINT: 1117 con.crval = a8tol(cn[2]); 1118 goto restcon; 1119 case T_INT: 1120 con.crval = atof(cn[2]); 1121 if (con.crval > MAXINT || con.crval < MININT) { 1122 derror("Constant too large for this implementation"); 1123 con.crval = 0; 1124 } 1125 restcon: 1126 ci = con.crval; 1127 #ifndef PI0 1128 if (bytes(ci, ci) <= 2) 1129 con.ctype = nl+T2INT; 1130 else 1131 #endif 1132 con.ctype = nl+T4INT; 1133 break; 1134 case T_FINT: 1135 con.ctype = nl+TDOUBLE; 1136 con.crval = atof(cn[2]); 1137 break; 1138 case T_STRNG: 1139 cp = cn[2]; 1140 if (cp[1] == 0) { 1141 con.ctype = nl+T1CHAR; 1142 con.cival = cp[0]; 1143 con.crval = con.cival; 1144 break; 1145 } 1146 con.ctype = nl+TSTR; 1147 con.cpval = cp; 1148 break; 1149 } 1150 if (sgnd) { 1151 if (isnta(con.ctype, "id")) { 1152 derror("%s constants cannot be signed", nameof(con.ctype)); 1153 return FALSE; 1154 } else if (negd) 1155 con.crval = -con.crval; 1156 } 1157 return TRUE; 1158 } 1159