1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)rval.c 1.17 10/30/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 if (p != nl+TNIL && p1 != nl+TNIL && p != p1) 847 goto nonident; 848 break; 849 case TSTR: 850 if (c1 != TSTR) 851 goto clash; 852 if (width(p) != width(p1)) { 853 error("Strings not same length in %s comparison", opname); 854 return (NIL); 855 } 856 g = TSTR; 857 break; 858 default: 859 panic("rval2"); 860 } 861 # ifdef OBJ 862 return (gen(g, r[0], width(p), width(p1))); 863 # endif OBJ 864 # ifdef PC 865 return nl + TBOOL; 866 # endif PC 867 clash: 868 error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname); 869 return (NIL); 870 nonident: 871 error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname); 872 return (NIL); 873 874 case T_IN: 875 rt = r[3]; 876 # ifdef OBJ 877 if (rt != NIL && rt[0] == T_CSET) { 878 precset( rt , NIL , &csetd ); 879 p1 = csetd.csettype; 880 if (p1 == NIL) 881 return NIL; 882 postcset( rt, &csetd); 883 } else { 884 p1 = stkrval(r[3], NIL , RREQ ); 885 rt = NIL; 886 } 887 # endif OBJ 888 # ifdef PC 889 if (rt != NIL && rt[0] == T_CSET) { 890 if ( precset( rt , NIL , &csetd ) ) { 891 putleaf( P2ICON , 0 , 0 892 , ADDTYPE( P2FTN | P2INT , P2PTR ) 893 , "_IN" ); 894 } else { 895 putleaf( P2ICON , 0 , 0 896 , ADDTYPE( P2FTN | P2INT , P2PTR ) 897 , "_INCT" ); 898 } 899 p1 = csetd.csettype; 900 if (p1 == NIL) 901 return NIL; 902 } else { 903 putleaf( P2ICON , 0 , 0 904 , ADDTYPE( P2FTN | P2INT , P2PTR ) 905 , "_IN" ); 906 codeoff(); 907 p1 = rvalue(r[3], NIL , LREQ ); 908 codeon(); 909 } 910 # endif PC 911 p = stkrval(r[2], NIL , RREQ ); 912 if (p == NIL || p1 == NIL) 913 return (NIL); 914 if (p1->class != SET) { 915 error("Right operand of 'in' must be a set, not %s", nameof(p1)); 916 return (NIL); 917 } 918 if (incompat(p, p1->type, r[2])) { 919 cerror("Index type clashed with set component type for 'in'"); 920 return (NIL); 921 } 922 setran(p1->type); 923 # ifdef OBJ 924 if (rt == NIL || csetd.comptime) 925 put(4, O_IN, width(p1), set.lwrb, set.uprbp); 926 else 927 put(2, O_INCT, 928 (int)(3 + csetd.singcnt + 2*csetd.paircnt)); 929 # endif OBJ 930 # ifdef PC 931 if ( rt == NIL || rt[0] != T_CSET ) { 932 putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 ); 933 putop( P2LISTOP , P2INT ); 934 putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 ); 935 putop( P2LISTOP , P2INT ); 936 p1 = rvalue( r[3] , NIL , LREQ ); 937 if ( p1 == NIL ) { 938 return NIL; 939 } 940 putop( P2LISTOP , P2INT ); 941 } else if ( csetd.comptime ) { 942 putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 ); 943 putop( P2LISTOP , P2INT ); 944 putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 ); 945 putop( P2LISTOP , P2INT ); 946 postcset( r[3] , &csetd ); 947 putop( P2LISTOP , P2INT ); 948 } else { 949 postcset( r[3] , &csetd ); 950 } 951 putop( P2CALL , P2INT ); 952 sconv(P2INT, P2CHAR); 953 # endif PC 954 return (nl+T1BOOL); 955 default: 956 if (r[2] == NIL) 957 return (NIL); 958 switch (r[0]) { 959 default: 960 panic("rval3"); 961 962 963 /* 964 * An octal number 965 */ 966 case T_BINT: 967 f = a8tol(r[2]); 968 goto conint; 969 970 /* 971 * A decimal number 972 */ 973 case T_INT: 974 f = atof(r[2]); 975 conint: 976 if (f > MAXINT || f < MININT) { 977 error("Constant too large for this implementation"); 978 return (NIL); 979 } 980 l = f; 981 # ifdef OBJ 982 if (bytes(l, l) <= 2) { 983 put(2, O_CON2, ( short ) l); 984 return (nl+T2INT); 985 } 986 put(2, O_CON4, l); 987 return (nl+T4INT); 988 # endif OBJ 989 # ifdef PC 990 switch (bytes(l, l)) { 991 case 1: 992 putleaf(P2ICON, l, 0, P2CHAR, 0); 993 return nl+T1INT; 994 case 2: 995 putleaf(P2ICON, l, 0, P2SHORT, 0); 996 return nl+T2INT; 997 case 4: 998 putleaf(P2ICON, l, 0, P2INT, 0); 999 return nl+T4INT; 1000 } 1001 # endif PC 1002 1003 /* 1004 * A floating point number 1005 */ 1006 case T_FINT: 1007 # ifdef OBJ 1008 put(2, O_CON8, atof(r[2])); 1009 # endif OBJ 1010 # ifdef PC 1011 putCON8( atof( r[2] ) ); 1012 # endif PC 1013 return (nl+TDOUBLE); 1014 1015 /* 1016 * Constant strings. Note that constant characters 1017 * are constant strings of length one; there is 1018 * no constant string of length one. 1019 */ 1020 case T_STRNG: 1021 cp = r[2]; 1022 if (cp[1] == 0) { 1023 # ifdef OBJ 1024 put(2, O_CONC, cp[0]); 1025 # endif OBJ 1026 # ifdef PC 1027 putleaf( P2ICON , cp[0] , 0 , P2CHAR , 0 ); 1028 # endif PC 1029 return (nl+T1CHAR); 1030 } 1031 goto cstrng; 1032 } 1033 1034 } 1035 } 1036 1037 /* 1038 * Can a class appear 1039 * in a comparison ? 1040 */ 1041 nocomp(c) 1042 int c; 1043 { 1044 1045 switch (c) { 1046 case TREC: 1047 if ( line != reccompline ) { 1048 reccompline = line; 1049 warning(); 1050 if ( opt( 's' ) ) { 1051 standard(); 1052 } 1053 error("record comparison is non-standard"); 1054 } 1055 break; 1056 case TFILE: 1057 case TARY: 1058 error("%ss may not participate in comparisons", clnames[c]); 1059 return (1); 1060 } 1061 return (NIL); 1062 } 1063 1064 /* 1065 * this is sort of like gconst, except it works on expression trees 1066 * rather than declaration trees, and doesn't give error messages for 1067 * non-constant things. 1068 * as a side effect this fills in the con structure that gconst uses. 1069 * this returns TRUE or FALSE. 1070 */ 1071 constval(r) 1072 register int *r; 1073 { 1074 register struct nl *np; 1075 register *cn; 1076 char *cp; 1077 int negd, sgnd; 1078 long ci; 1079 1080 con.ctype = NIL; 1081 cn = r; 1082 negd = sgnd = 0; 1083 loop: 1084 /* 1085 * cn[2] is nil if error recovery generated a T_STRNG 1086 */ 1087 if (cn == NIL || cn[2] == NIL) 1088 return FALSE; 1089 switch (cn[0]) { 1090 default: 1091 return FALSE; 1092 case T_MINUS: 1093 negd = 1 - negd; 1094 /* and fall through */ 1095 case T_PLUS: 1096 sgnd++; 1097 cn = cn[2]; 1098 goto loop; 1099 case T_NIL: 1100 con.cpval = NIL; 1101 con.cival = 0; 1102 con.crval = con.cival; 1103 con.ctype = nl + TNIL; 1104 break; 1105 case T_VAR: 1106 np = lookup(cn[2]); 1107 if (np == NIL || np->class != CONST) { 1108 return FALSE; 1109 } 1110 if ( cn[3] != NIL ) { 1111 return FALSE; 1112 } 1113 con.ctype = np->type; 1114 switch (classify(np->type)) { 1115 case TINT: 1116 con.crval = np->range[0]; 1117 break; 1118 case TDOUBLE: 1119 con.crval = np->real; 1120 break; 1121 case TBOOL: 1122 case TCHAR: 1123 case TSCAL: 1124 con.cival = np->value[0]; 1125 con.crval = con.cival; 1126 break; 1127 case TSTR: 1128 con.cpval = np->ptr[0]; 1129 break; 1130 default: 1131 con.ctype = NIL; 1132 return FALSE; 1133 } 1134 break; 1135 case T_BINT: 1136 con.crval = a8tol(cn[2]); 1137 goto restcon; 1138 case T_INT: 1139 con.crval = atof(cn[2]); 1140 if (con.crval > MAXINT || con.crval < MININT) { 1141 derror("Constant too large for this implementation"); 1142 con.crval = 0; 1143 } 1144 restcon: 1145 ci = con.crval; 1146 #ifndef PI0 1147 if (bytes(ci, ci) <= 2) 1148 con.ctype = nl+T2INT; 1149 else 1150 #endif 1151 con.ctype = nl+T4INT; 1152 break; 1153 case T_FINT: 1154 con.ctype = nl+TDOUBLE; 1155 con.crval = atof(cn[2]); 1156 break; 1157 case T_STRNG: 1158 cp = cn[2]; 1159 if (cp[1] == 0) { 1160 con.ctype = nl+T1CHAR; 1161 con.cival = cp[0]; 1162 con.crval = con.cival; 1163 break; 1164 } 1165 con.ctype = nl+TSTR; 1166 con.cpval = cp; 1167 break; 1168 } 1169 if (sgnd) { 1170 if (isnta(con.ctype, "id")) { 1171 derror("%s constants cannot be signed", nameof(con.ctype)); 1172 return FALSE; 1173 } else if (negd) 1174 con.crval = -con.crval; 1175 } 1176 return TRUE; 1177 } 1178