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