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