1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)rval.c 1.10 03/11/81"; 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, 129 (int)p->value[0]); 130 break; 131 case 4: 132 put(2, O_RV4 | bn << 8+INDX, 133 (int)p->value[0]); 134 break; 135 case 2: 136 put(2, O_RV2 | bn << 8+INDX, 137 (int)p->value[0]); 138 break; 139 case 1: 140 put(2, O_RV1 | bn << 8+INDX, 141 (int)p->value[0]); 142 break; 143 default: 144 put(3, O_RV | bn << 8+INDX, 145 (int)p->value[0], w); 146 } 147 # endif OBJ 148 # ifdef PC 149 if ( required == RREQ ) { 150 putRV( p -> symbol , bn , p -> value[0] 151 , p2type( q ) ); 152 } else { 153 putLV( p -> symbol , bn , p -> value[0] 154 , p2type( q ) ); 155 } 156 # endif PC 157 return (q); 158 159 case WITHPTR: 160 case REF: 161 /* 162 * A lvalue for these 163 * is actually what one 164 * might consider a rvalue. 165 */ 166 ind: 167 q = lvalue(r, NOFLAGS , LREQ ); 168 if (q == NIL) 169 return (NIL); 170 # ifdef OBJ 171 w = width(q); 172 switch (w) { 173 case 8: 174 put(1, O_IND8); 175 break; 176 case 4: 177 put(1, O_IND4); 178 break; 179 case 2: 180 put(1, O_IND2); 181 break; 182 case 1: 183 put(1, O_IND1); 184 break; 185 default: 186 put(2, O_IND, w); 187 } 188 # endif OBJ 189 # ifdef PC 190 if ( required == RREQ ) { 191 putop( P2UNARY P2MUL , p2type( q ) ); 192 } 193 # endif PC 194 return (q); 195 196 case CONST: 197 if (r[3] != NIL) { 198 error("%s is a constant and cannot be qualified", r[2]); 199 return (NIL); 200 } 201 q = p->type; 202 if (q == NIL) 203 return (NIL); 204 if (q == nl+TSTR) { 205 /* 206 * Find the size of the string 207 * constant if needed. 208 */ 209 cp = p->ptr[0]; 210 cstrng: 211 cp1 = cp; 212 for (c = 0; *cp++; c++) 213 continue; 214 w = c; 215 if (contype != NIL && !opt('s')) { 216 if (width(contype) < c && classify(contype) == TSTR) { 217 error("Constant string too long"); 218 return (NIL); 219 } 220 w = width(contype); 221 } 222 # ifdef OBJ 223 put(2, O_CONG, w); 224 putstr(cp1, w - c); 225 # endif OBJ 226 # ifdef PC 227 putCONG( cp1 , w , required ); 228 # endif PC 229 /* 230 * Define the string temporarily 231 * so later people can know its 232 * width. 233 * cleaned out by stat. 234 */ 235 q = defnl(0, STR, 0, w); 236 q->type = q; 237 return (q); 238 } 239 if (q == nl+T1CHAR) { 240 # ifdef OBJ 241 put(2, O_CONC, (int)p->value[0]); 242 # endif OBJ 243 # ifdef PC 244 putleaf( P2ICON , p -> value[0] , 0 245 , P2CHAR , 0 ); 246 # endif PC 247 return (q); 248 } 249 /* 250 * Every other kind of constant here 251 */ 252 switch (width(q)) { 253 case 8: 254 #ifndef DEBUG 255 # ifdef OBJ 256 put(2, O_CON8, p->real); 257 # endif OBJ 258 # ifdef PC 259 putCON8( p -> real ); 260 # endif PC 261 #else 262 if (hp21mx) { 263 f = p->real; 264 conv(&f); 265 l = f.plong; 266 put(2, O_CON4, l); 267 } else 268 # ifdef OBJ 269 put(2, O_CON8, p->real); 270 # endif OBJ 271 # ifdef PC 272 putCON8( p -> real ); 273 # endif PC 274 #endif 275 break; 276 case 4: 277 # ifdef OBJ 278 put(2, O_CON4, p->range[0]); 279 # endif OBJ 280 # ifdef PC 281 putleaf( P2ICON , p -> range[0] , 0 282 , P2INT , 0 ); 283 # endif PC 284 break; 285 case 2: 286 # ifdef OBJ 287 put(2, O_CON2, (short)p->range[0]); 288 # endif OBJ 289 # ifdef PC 290 /* 291 * make short constants ints 292 */ 293 putleaf( P2ICON , (short) p -> range[0] 294 , 0 , P2INT , 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 /* 303 * make char constants ints 304 */ 305 putleaf( P2ICON , p -> value[0] , 0 306 , P2INT , 0 ); 307 # endif PC 308 break; 309 default: 310 panic("rval"); 311 } 312 return (q); 313 314 case FUNC: 315 case FFUNC: 316 /* 317 * Function call with no arguments. 318 */ 319 if (r[3]) { 320 error("Can't qualify a function result value"); 321 return (NIL); 322 } 323 # ifdef OBJ 324 return (funccod((int *) r)); 325 # endif OBJ 326 # ifdef PC 327 return (pcfunccod( r )); 328 # endif PC 329 330 case TYPE: 331 error("Type names (e.g. %s) allowed only in declarations", p->symbol); 332 return (NIL); 333 334 case PROC: 335 case FPROC: 336 error("Procedure %s found where expression required", p->symbol); 337 return (NIL); 338 default: 339 panic("rvid"); 340 } 341 /* 342 * Constant sets 343 */ 344 case T_CSET: 345 # ifdef OBJ 346 if ( precset( r , contype , &csetd ) ) { 347 if ( csetd.csettype == NIL ) { 348 return NIL; 349 } 350 postcset( r , &csetd ); 351 } else { 352 put( 2, O_PUSH, -lwidth(csetd.csettype)); 353 postcset( r , &csetd ); 354 setran( ( csetd.csettype ) -> type ); 355 put( 2, O_CON24, set.uprbp); 356 put( 2, O_CON24, set.lwrb); 357 put( 2, O_CTTOT, 358 (int)(4 + csetd.singcnt + 2 * csetd.paircnt)); 359 } 360 return csetd.csettype; 361 # endif OBJ 362 # ifdef PC 363 if ( precset( r , contype , &csetd ) ) { 364 if ( csetd.csettype == NIL ) { 365 return NIL; 366 } 367 postcset( r , &csetd ); 368 } else { 369 putleaf( P2ICON , 0 , 0 370 , ADDTYPE( P2FTN | P2INT , P2PTR ) 371 , "_CTTOT" ); 372 /* 373 * allocate a temporary and use it 374 */ 375 tempoff = tmpalloc(lwidth(csetd.csettype), 376 csetd.csettype, NOREG); 377 putLV( 0 , cbn , tempoff , P2PTR|P2STRTY ); 378 setran( ( csetd.csettype ) -> type ); 379 putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 ); 380 putop( P2LISTOP , P2INT ); 381 putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 ); 382 putop( P2LISTOP , P2INT ); 383 postcset( r , &csetd ); 384 putop( P2CALL , P2INT ); 385 } 386 return csetd.csettype; 387 # endif PC 388 389 /* 390 * Unary plus and minus 391 */ 392 case T_PLUS: 393 case T_MINUS: 394 q = rvalue(r[2], NIL , RREQ ); 395 if (q == NIL) 396 return (NIL); 397 if (isnta(q, "id")) { 398 error("Operand of %s must be integer or real, not %s", opname, nameof(q)); 399 return (NIL); 400 } 401 if (r[0] == T_MINUS) { 402 # ifdef OBJ 403 put(1, O_NEG2 + (width(q) >> 2)); 404 # endif OBJ 405 # ifdef PC 406 putop( P2UNARY P2MINUS , p2type( q ) ); 407 # endif PC 408 return (isa(q, "d") ? q : nl+T4INT); 409 } 410 return (q); 411 412 case T_NOT: 413 q = rvalue(r[2], NIL , RREQ ); 414 if (q == NIL) 415 return (NIL); 416 if (isnta(q, "b")) { 417 error("not must operate on a Boolean, not %s", nameof(q)); 418 return (NIL); 419 } 420 # ifdef OBJ 421 put(1, O_NOT); 422 # endif OBJ 423 # ifdef PC 424 putop( P2NOT , P2INT ); 425 # endif PC 426 return (nl+T1BOOL); 427 428 case T_AND: 429 case T_OR: 430 p = rvalue(r[2], NIL , RREQ ); 431 p1 = rvalue(r[3], NIL , RREQ ); 432 if (p == NIL || p1 == NIL) 433 return (NIL); 434 if (isnta(p, "b")) { 435 error("Left operand of %s must be Boolean, not %s", opname, nameof(p)); 436 return (NIL); 437 } 438 if (isnta(p1, "b")) { 439 error("Right operand of %s must be Boolean, not %s", opname, nameof(p1)); 440 return (NIL); 441 } 442 # ifdef OBJ 443 put(1, r[0] == T_AND ? O_AND : O_OR); 444 # endif OBJ 445 # ifdef PC 446 /* 447 * note the use of & and | rather than && and || 448 * to force evaluation of all the expressions. 449 */ 450 putop( r[ 0 ] == T_AND ? P2AND : P2OR , P2INT ); 451 # endif PC 452 return (nl+T1BOOL); 453 454 case T_DIVD: 455 # ifdef OBJ 456 p = rvalue(r[2], NIL , RREQ ); 457 p1 = rvalue(r[3], NIL , RREQ ); 458 # endif OBJ 459 # ifdef PC 460 /* 461 * force these to be doubles for the divide 462 */ 463 p = rvalue( r[ 2 ] , NIL , RREQ ); 464 if ( isnta( p , "d" ) ) { 465 putop( P2SCONV , P2DOUBLE ); 466 } 467 p1 = rvalue( r[ 3 ] , NIL , RREQ ); 468 if ( isnta( p1 , "d" ) ) { 469 putop( P2SCONV , P2DOUBLE ); 470 } 471 # endif PC 472 if (p == NIL || p1 == NIL) 473 return (NIL); 474 if (isnta(p, "id")) { 475 error("Left operand of / must be integer or real, not %s", nameof(p)); 476 return (NIL); 477 } 478 if (isnta(p1, "id")) { 479 error("Right operand of / must be integer or real, not %s", nameof(p1)); 480 return (NIL); 481 } 482 # ifdef OBJ 483 return gen(NIL, r[0], width(p), width(p1)); 484 # endif OBJ 485 # ifdef PC 486 putop( P2DIV , P2DOUBLE ); 487 return nl + TDOUBLE; 488 # endif PC 489 490 case T_MULT: 491 case T_ADD: 492 case T_SUB: 493 # ifdef OBJ 494 /* 495 * If the context hasn't told us the type 496 * and a constant set is present 497 * we need to infer the type 498 * before generating code. 499 */ 500 if ( contype == NIL ) { 501 codeoff(); 502 contype = rvalue( r[3] , NIL , RREQ ); 503 codeon(); 504 if ( contype == lookup( intset ) -> type ) { 505 codeoff(); 506 contype = rvalue( r[2] , NIL , RREQ ); 507 codeon(); 508 } 509 } 510 if ( contype == NIL ) { 511 return NIL; 512 } 513 p = rvalue( r[2] , contype , RREQ ); 514 p1 = rvalue( r[3] , p , RREQ ); 515 if ( p == NIL || p1 == NIL ) 516 return NIL; 517 if (isa(p, "id") && isa(p1, "id")) 518 return (gen(NIL, r[0], width(p), width(p1))); 519 if (isa(p, "t") && isa(p1, "t")) { 520 if (p != p1) { 521 error("Set types of operands of %s must be identical", opname); 522 return (NIL); 523 } 524 gen(TSET, r[0], width(p), 0); 525 return (p); 526 } 527 # endif OBJ 528 # ifdef PC 529 /* 530 * the second pass can't do 531 * long op double or double op long 532 * so we have to know the type of both operands 533 * also, it gets tricky for sets, which are done 534 * by function calls. 535 */ 536 codeoff(); 537 p1 = rvalue( r[ 3 ] , contype , RREQ ); 538 codeon(); 539 if ( isa( p1 , "id" ) ) { 540 p = rvalue( r[ 2 ] , contype , RREQ ); 541 if ( ( p == NIL ) || ( p1 == NIL ) ) { 542 return NIL; 543 } 544 if ( isa( p , "i" ) && isa( p1 , "d" ) ) { 545 putop( P2SCONV , P2DOUBLE ); 546 } 547 p1 = rvalue( r[ 3 ] , contype , RREQ ); 548 if ( isa( p , "d" ) && isa( p1 , "i" ) ) { 549 putop( P2SCONV , P2DOUBLE ); 550 } 551 if ( isa( p , "id" ) ) { 552 if ( isa( p , "d" ) || isa( p1 , "d" ) ) { 553 ctype = P2DOUBLE; 554 rettype = nl + TDOUBLE; 555 } else { 556 ctype = P2INT; 557 rettype = nl + T4INT; 558 } 559 putop( mathop[ r[0] - T_MULT ] , ctype ); 560 return rettype; 561 } 562 } 563 if ( isa( p1 , "t" ) ) { 564 putleaf( P2ICON , 0 , 0 565 , ADDTYPE( ADDTYPE( P2PTR | P2STRTY , P2FTN ) 566 , P2PTR ) 567 , setop[ r[0] - T_MULT ] ); 568 if ( contype == NIL ) { 569 contype = p1; 570 if ( contype == lookup( intset ) -> type ) { 571 codeoff(); 572 contype = rvalue( r[2] , NIL , LREQ ); 573 codeon(); 574 } 575 } 576 if ( contype == NIL ) { 577 return NIL; 578 } 579 /* 580 * allocate a temporary and use it 581 */ 582 tempoff = tmpalloc(lwidth(contype), contype, NOREG); 583 putLV( 0 , cbn , tempoff , P2PTR|P2STRTY ); 584 p = rvalue( r[2] , contype , LREQ ); 585 if ( isa( p , "t" ) ) { 586 putop( P2LISTOP , P2INT ); 587 if ( p == NIL || p1 == NIL ) { 588 return NIL; 589 } 590 p1 = rvalue( r[3] , p , LREQ ); 591 if ( p != p1 ) { 592 error("Set types of operands of %s must be identical", opname); 593 return NIL; 594 } 595 putop( P2LISTOP , P2INT ); 596 putleaf( P2ICON , lwidth( p1 ) / sizeof( long ) , 0 597 , P2INT , 0 ); 598 putop( P2LISTOP , P2INT ); 599 putop( P2CALL , P2PTR | P2STRTY ); 600 return p; 601 } 602 } 603 if ( isnta( p1 , "idt" ) ) { 604 /* 605 * find type of left operand for error message. 606 */ 607 p = rvalue( r[2] , contype , RREQ ); 608 } 609 /* 610 * don't give spurious error messages. 611 */ 612 if ( p == NIL || p1 == NIL ) { 613 return NIL; 614 } 615 # endif PC 616 if (isnta(p, "idt")) { 617 error("Left operand of %s must be integer, real or set, not %s", opname, nameof(p)); 618 return (NIL); 619 } 620 if (isnta(p1, "idt")) { 621 error("Right operand of %s must be integer, real or set, not %s", opname, nameof(p1)); 622 return (NIL); 623 } 624 error("Cannot mix sets with integers and reals as operands of %s", opname); 625 return (NIL); 626 627 case T_MOD: 628 case T_DIV: 629 p = rvalue(r[2], NIL , RREQ ); 630 p1 = rvalue(r[3], NIL , RREQ ); 631 if (p == NIL || p1 == NIL) 632 return (NIL); 633 if (isnta(p, "i")) { 634 error("Left operand of %s must be integer, not %s", opname, nameof(p)); 635 return (NIL); 636 } 637 if (isnta(p1, "i")) { 638 error("Right operand of %s must be integer, not %s", opname, nameof(p1)); 639 return (NIL); 640 } 641 # ifdef OBJ 642 return (gen(NIL, r[0], width(p), width(p1))); 643 # endif OBJ 644 # ifdef PC 645 putop( r[ 0 ] == T_DIV ? P2DIV : P2MOD , P2INT ); 646 return ( nl + T4INT ); 647 # endif PC 648 649 case T_EQ: 650 case T_NE: 651 case T_LT: 652 case T_GT: 653 case T_LE: 654 case T_GE: 655 /* 656 * Since there can be no, a priori, knowledge 657 * of the context type should a constant string 658 * or set arise, we must poke around to find such 659 * a type if possible. Since constant strings can 660 * always masquerade as identifiers, this is always 661 * necessary. 662 */ 663 codeoff(); 664 p1 = rvalue(r[3], NIL , RREQ ); 665 codeon(); 666 if (p1 == NIL) 667 return (NIL); 668 contype = p1; 669 # ifdef OBJ 670 if (p1->class == STR) { 671 /* 672 * For constant strings we want 673 * the longest type so as to be 674 * able to do padding (more importantly 675 * avoiding truncation). For clarity, 676 * we get this length here. 677 */ 678 codeoff(); 679 p = rvalue(r[2], NIL , RREQ ); 680 codeon(); 681 if (p == NIL) 682 return (NIL); 683 if (width(p) > width(p1)) 684 contype = p; 685 } else if ( isa( p1 , "t" ) ) { 686 if ( contype == lookup( intset ) -> type ) { 687 codeoff(); 688 contype = rvalue( r[2] , NIL , RREQ ); 689 codeon(); 690 if ( contype == NIL ) { 691 return NIL; 692 } 693 } 694 } 695 /* 696 * Now we generate code for 697 * the operands of the relational 698 * operation. 699 */ 700 p = rvalue(r[2], contype , RREQ ); 701 if (p == NIL) 702 return (NIL); 703 p1 = rvalue(r[3], p , RREQ ); 704 if (p1 == NIL) 705 return (NIL); 706 # endif OBJ 707 # ifdef PC 708 c1 = classify( p1 ); 709 if ( c1 == TSET || c1 == TSTR || c1 == TREC ) { 710 putleaf( P2ICON , 0 , 0 711 , ADDTYPE( P2FTN | P2INT , P2PTR ) 712 , c1 == TSET ? relts[ r[0] - T_EQ ] 713 : relss[ r[0] - T_EQ ] ); 714 /* 715 * for [] and strings, comparisons are done on 716 * the maximum width of the two sides. 717 * for other sets, we have to ask the left side 718 * what type it is based on the type of the right. 719 * (this matters for intsets). 720 */ 721 if ( c1 == TSTR ) { 722 codeoff(); 723 p = rvalue( r[ 2 ] , NIL , LREQ ); 724 codeon(); 725 if ( p == NIL ) { 726 return NIL; 727 } 728 if ( lwidth( p ) > lwidth( p1 ) ) { 729 contype = p; 730 } 731 } else if ( c1 == TSET ) { 732 if ( contype == lookup( intset ) -> type ) { 733 codeoff(); 734 p = rvalue( r[ 2 ] , NIL , LREQ ); 735 codeon(); 736 if ( p == NIL ) { 737 return NIL; 738 } 739 contype = p; 740 } 741 } 742 /* 743 * put out the width of the comparison. 744 */ 745 putleaf( P2ICON , lwidth( contype ) , 0 , P2INT , 0 ); 746 /* 747 * and the left hand side, 748 * for sets, strings, records 749 */ 750 p = rvalue( r[ 2 ] , contype , LREQ ); 751 putop( P2LISTOP , P2INT ); 752 p1 = rvalue( r[ 3 ] , p , LREQ ); 753 putop( P2LISTOP , P2INT ); 754 putop( P2CALL , P2INT ); 755 } else { 756 /* 757 * the easy (scalar or error) case 758 */ 759 p = rvalue( r[ 2 ] , contype , RREQ ); 760 if ( p == NIL ) { 761 return NIL; 762 } 763 /* 764 * since the second pass can't do 765 * long op double or double op long 766 * we may have to do some coercing. 767 */ 768 if ( isa( p , "i" ) && isa( p1 , "d" ) ) { 769 putop( P2SCONV , P2DOUBLE ); 770 } 771 p1 = rvalue( r[ 3 ] , p , RREQ ); 772 if ( isa( p , "d" ) && isa( p1 , "i" ) ) 773 putop( P2SCONV , P2DOUBLE ); 774 putop( relops[ r[0] - T_EQ ] , P2INT ); 775 } 776 # endif PC 777 c = classify(p); 778 c1 = classify(p1); 779 if (nocomp(c) || nocomp(c1)) 780 return (NIL); 781 g = NIL; 782 switch (c) { 783 case TBOOL: 784 case TCHAR: 785 if (c != c1) 786 goto clash; 787 break; 788 case TINT: 789 case TDOUBLE: 790 if (c1 != TINT && c1 != TDOUBLE) 791 goto clash; 792 break; 793 case TSCAL: 794 if (c1 != TSCAL) 795 goto clash; 796 if (scalar(p) != scalar(p1)) 797 goto nonident; 798 break; 799 case TSET: 800 if (c1 != TSET) 801 goto clash; 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 break; 828 case TSTR: 829 if (c1 != TSTR) 830 goto clash; 831 if (width(p) != width(p1)) { 832 error("Strings not same length in %s comparison", opname); 833 return (NIL); 834 } 835 g = TSTR; 836 break; 837 default: 838 panic("rval2"); 839 } 840 # ifdef OBJ 841 return (gen(g, r[0], width(p), width(p1))); 842 # endif OBJ 843 # ifdef PC 844 return nl + TBOOL; 845 # endif PC 846 clash: 847 error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname); 848 return (NIL); 849 nonident: 850 error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname); 851 return (NIL); 852 853 case T_IN: 854 rt = r[3]; 855 # ifdef OBJ 856 if (rt != NIL && rt[0] == T_CSET) { 857 precset( rt , NIL , &csetd ); 858 p1 = csetd.csettype; 859 if (p1 == NIL) 860 return NIL; 861 postcset( rt, &csetd); 862 } else { 863 p1 = stkrval(r[3], NIL , RREQ ); 864 rt = NIL; 865 } 866 # endif OBJ 867 # ifdef PC 868 if (rt != NIL && rt[0] == T_CSET) { 869 if ( precset( rt , NIL , &csetd ) ) { 870 putleaf( P2ICON , 0 , 0 871 , ADDTYPE( P2FTN | P2INT , P2PTR ) 872 , "_IN" ); 873 } else { 874 putleaf( P2ICON , 0 , 0 875 , ADDTYPE( P2FTN | P2INT , P2PTR ) 876 , "_INCT" ); 877 } 878 p1 = csetd.csettype; 879 if (p1 == NIL) 880 return NIL; 881 } else { 882 putleaf( P2ICON , 0 , 0 883 , ADDTYPE( P2FTN | P2INT , P2PTR ) 884 , "_IN" ); 885 codeoff(); 886 p1 = rvalue(r[3], NIL , LREQ ); 887 codeon(); 888 } 889 # endif PC 890 p = stkrval(r[2], NIL , RREQ ); 891 if (p == NIL || p1 == NIL) 892 return (NIL); 893 if (p1->class != SET) { 894 error("Right operand of 'in' must be a set, not %s", nameof(p1)); 895 return (NIL); 896 } 897 if (incompat(p, p1->type, r[2])) { 898 cerror("Index type clashed with set component type for 'in'"); 899 return (NIL); 900 } 901 setran(p1->type); 902 # ifdef OBJ 903 if (rt == NIL || csetd.comptime) 904 put(4, O_IN, width(p1), set.lwrb, set.uprbp); 905 else 906 put(2, O_INCT, 907 (int)(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 } 1151