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