1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)rval.c 1.12 06/01/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 /* 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 /* 293 * make short constants ints 294 */ 295 putleaf( P2ICON , (short) p -> range[0] 296 , 0 , P2INT , 0 ); 297 # endif PC 298 break; 299 case 1: 300 # ifdef OBJ 301 put(2, O_CON1, p->value[0]); 302 # endif OBJ 303 # ifdef PC 304 /* 305 * make char constants ints 306 */ 307 putleaf( P2ICON , p -> value[0] , 0 308 , P2INT , 0 ); 309 # endif PC 310 break; 311 default: 312 panic("rval"); 313 } 314 return (q); 315 316 case FUNC: 317 case FFUNC: 318 /* 319 * Function call with no arguments. 320 */ 321 if (r[3]) { 322 error("Can't qualify a function result value"); 323 return (NIL); 324 } 325 # ifdef OBJ 326 return (funccod((int *) r)); 327 # endif OBJ 328 # ifdef PC 329 return (pcfunccod( r )); 330 # endif PC 331 332 case TYPE: 333 error("Type names (e.g. %s) allowed only in declarations", p->symbol); 334 return (NIL); 335 336 case PROC: 337 case FPROC: 338 error("Procedure %s found where expression required", p->symbol); 339 return (NIL); 340 default: 341 panic("rvid"); 342 } 343 /* 344 * Constant sets 345 */ 346 case T_CSET: 347 # ifdef OBJ 348 if ( precset( r , contype , &csetd ) ) { 349 if ( csetd.csettype == NIL ) { 350 return NIL; 351 } 352 postcset( r , &csetd ); 353 } else { 354 put( 2, O_PUSH, -lwidth(csetd.csettype)); 355 postcset( r , &csetd ); 356 setran( ( csetd.csettype ) -> type ); 357 put( 2, O_CON24, set.uprbp); 358 put( 2, O_CON24, set.lwrb); 359 put( 2, O_CTTOT, 360 (int)(4 + csetd.singcnt + 2 * csetd.paircnt)); 361 } 362 return csetd.csettype; 363 # endif OBJ 364 # ifdef PC 365 if ( precset( r , contype , &csetd ) ) { 366 if ( csetd.csettype == NIL ) { 367 return NIL; 368 } 369 postcset( r , &csetd ); 370 } else { 371 putleaf( P2ICON , 0 , 0 372 , ADDTYPE( P2FTN | P2INT , P2PTR ) 373 , "_CTTOT" ); 374 /* 375 * allocate a temporary and use it 376 */ 377 tempnlp = tmpalloc(lwidth(csetd.csettype), 378 csetd.csettype, NOREG); 379 putLV( 0 , cbn , tempnlp -> value[ NL_OFFS ] , 380 tempnlp -> extra_flags , P2PTR|P2STRTY ); 381 setran( ( csetd.csettype ) -> type ); 382 putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 ); 383 putop( P2LISTOP , P2INT ); 384 putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 ); 385 putop( P2LISTOP , P2INT ); 386 postcset( r , &csetd ); 387 putop( P2CALL , P2INT ); 388 } 389 return csetd.csettype; 390 # endif PC 391 392 /* 393 * Unary plus and minus 394 */ 395 case T_PLUS: 396 case T_MINUS: 397 q = rvalue(r[2], NIL , RREQ ); 398 if (q == NIL) 399 return (NIL); 400 if (isnta(q, "id")) { 401 error("Operand of %s must be integer or real, not %s", opname, nameof(q)); 402 return (NIL); 403 } 404 if (r[0] == T_MINUS) { 405 # ifdef OBJ 406 put(1, O_NEG2 + (width(q) >> 2)); 407 # endif OBJ 408 # ifdef PC 409 putop( P2UNARY P2MINUS , p2type( q ) ); 410 # endif PC 411 return (isa(q, "d") ? q : nl+T4INT); 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 putop( P2NOT , P2INT ); 428 # endif PC 429 return (nl+T1BOOL); 430 431 case T_AND: 432 case T_OR: 433 p = rvalue(r[2], NIL , RREQ ); 434 p1 = rvalue(r[3], NIL , RREQ ); 435 if (p == NIL || p1 == NIL) 436 return (NIL); 437 if (isnta(p, "b")) { 438 error("Left operand of %s must be Boolean, not %s", opname, nameof(p)); 439 return (NIL); 440 } 441 if (isnta(p1, "b")) { 442 error("Right operand of %s must be Boolean, not %s", opname, nameof(p1)); 443 return (NIL); 444 } 445 # ifdef OBJ 446 put(1, r[0] == T_AND ? O_AND : O_OR); 447 # endif OBJ 448 # ifdef PC 449 /* 450 * note the use of & and | rather than && and || 451 * to force evaluation of all the expressions. 452 */ 453 putop( r[ 0 ] == T_AND ? P2AND : P2OR , P2INT ); 454 # endif PC 455 return (nl+T1BOOL); 456 457 case T_DIVD: 458 # ifdef OBJ 459 p = rvalue(r[2], NIL , RREQ ); 460 p1 = rvalue(r[3], NIL , RREQ ); 461 # endif OBJ 462 # ifdef PC 463 /* 464 * force these to be doubles for the divide 465 */ 466 p = rvalue( r[ 2 ] , NIL , RREQ ); 467 if ( isnta( p , "d" ) ) { 468 putop( P2SCONV , P2DOUBLE ); 469 } 470 p1 = rvalue( r[ 3 ] , NIL , RREQ ); 471 if ( isnta( p1 , "d" ) ) { 472 putop( P2SCONV , P2DOUBLE ); 473 } 474 # endif PC 475 if (p == NIL || p1 == NIL) 476 return (NIL); 477 if (isnta(p, "id")) { 478 error("Left operand of / must be integer or real, not %s", nameof(p)); 479 return (NIL); 480 } 481 if (isnta(p1, "id")) { 482 error("Right operand of / must be integer or real, not %s", nameof(p1)); 483 return (NIL); 484 } 485 # ifdef OBJ 486 return gen(NIL, r[0], width(p), width(p1)); 487 # endif OBJ 488 # ifdef PC 489 putop( P2DIV , P2DOUBLE ); 490 return nl + TDOUBLE; 491 # endif PC 492 493 case T_MULT: 494 case T_ADD: 495 case T_SUB: 496 # ifdef OBJ 497 /* 498 * If the context hasn't told us the type 499 * and a constant set is present 500 * we need to infer the type 501 * before generating code. 502 */ 503 if ( contype == NIL ) { 504 codeoff(); 505 contype = rvalue( r[3] , NIL , RREQ ); 506 codeon(); 507 if ( contype == lookup( intset ) -> type ) { 508 codeoff(); 509 contype = rvalue( r[2] , NIL , RREQ ); 510 codeon(); 511 } 512 } 513 if ( contype == NIL ) { 514 return NIL; 515 } 516 p = rvalue( r[2] , contype , RREQ ); 517 p1 = rvalue( r[3] , p , RREQ ); 518 if ( p == NIL || p1 == NIL ) 519 return NIL; 520 if (isa(p, "id") && isa(p1, "id")) 521 return (gen(NIL, r[0], width(p), width(p1))); 522 if (isa(p, "t") && isa(p1, "t")) { 523 if (p != p1) { 524 error("Set types of operands of %s must be identical", opname); 525 return (NIL); 526 } 527 gen(TSET, r[0], width(p), 0); 528 return (p); 529 } 530 # endif OBJ 531 # ifdef PC 532 /* 533 * the second pass can't do 534 * long op double or double op long 535 * so we have to know the type of both operands 536 * also, it gets tricky for sets, which are done 537 * by function calls. 538 */ 539 codeoff(); 540 p1 = rvalue( r[ 3 ] , contype , RREQ ); 541 codeon(); 542 if ( isa( p1 , "id" ) ) { 543 p = rvalue( r[ 2 ] , contype , RREQ ); 544 if ( ( p == NIL ) || ( p1 == NIL ) ) { 545 return NIL; 546 } 547 if ( isa( p , "i" ) && isa( p1 , "d" ) ) { 548 putop( P2SCONV , P2DOUBLE ); 549 } 550 p1 = rvalue( r[ 3 ] , contype , RREQ ); 551 if ( isa( p , "d" ) && isa( p1 , "i" ) ) { 552 putop( P2SCONV , P2DOUBLE ); 553 } 554 if ( isa( p , "id" ) ) { 555 if ( isa( p , "d" ) || isa( p1 , "d" ) ) { 556 ctype = P2DOUBLE; 557 rettype = nl + TDOUBLE; 558 } else { 559 ctype = P2INT; 560 rettype = nl + T4INT; 561 } 562 putop( mathop[ r[0] - T_MULT ] , ctype ); 563 return rettype; 564 } 565 } 566 if ( isa( p1 , "t" ) ) { 567 putleaf( P2ICON , 0 , 0 568 , ADDTYPE( ADDTYPE( P2PTR | P2STRTY , P2FTN ) 569 , P2PTR ) 570 , setop[ r[0] - T_MULT ] ); 571 if ( contype == NIL ) { 572 contype = p1; 573 if ( contype == lookup( intset ) -> type ) { 574 codeoff(); 575 contype = rvalue( r[2] , NIL , LREQ ); 576 codeon(); 577 } 578 } 579 if ( contype == NIL ) { 580 return NIL; 581 } 582 /* 583 * allocate a temporary and use it 584 */ 585 tempnlp = tmpalloc(lwidth(contype), contype, NOREG); 586 putLV( 0 , cbn , tempnlp -> value[ NL_OFFS ] , 587 tempnlp -> extra_flags , P2PTR|P2STRTY ); 588 p = rvalue( r[2] , contype , LREQ ); 589 if ( isa( p , "t" ) ) { 590 putop( P2LISTOP , P2INT ); 591 if ( p == NIL || p1 == NIL ) { 592 return NIL; 593 } 594 p1 = rvalue( r[3] , p , LREQ ); 595 if ( p != p1 ) { 596 error("Set types of operands of %s must be identical", opname); 597 return NIL; 598 } 599 putop( P2LISTOP , P2INT ); 600 putleaf( P2ICON , lwidth( p1 ) / sizeof( long ) , 0 601 , P2INT , 0 ); 602 putop( P2LISTOP , P2INT ); 603 putop( P2CALL , P2PTR | P2STRTY ); 604 return p; 605 } 606 } 607 if ( isnta( p1 , "idt" ) ) { 608 /* 609 * find type of left operand for error message. 610 */ 611 p = rvalue( r[2] , contype , RREQ ); 612 } 613 /* 614 * don't give spurious error messages. 615 */ 616 if ( p == NIL || p1 == NIL ) { 617 return NIL; 618 } 619 # endif PC 620 if (isnta(p, "idt")) { 621 error("Left operand of %s must be integer, real or set, not %s", opname, nameof(p)); 622 return (NIL); 623 } 624 if (isnta(p1, "idt")) { 625 error("Right operand of %s must be integer, real or set, not %s", opname, nameof(p1)); 626 return (NIL); 627 } 628 error("Cannot mix sets with integers and reals as operands of %s", opname); 629 return (NIL); 630 631 case T_MOD: 632 case T_DIV: 633 p = rvalue(r[2], NIL , RREQ ); 634 p1 = rvalue(r[3], NIL , RREQ ); 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 putop( P2LISTOP , P2INT ); 756 p1 = rvalue( r[ 3 ] , p , LREQ ); 757 putop( P2LISTOP , P2INT ); 758 putop( P2CALL , P2INT ); 759 } else { 760 /* 761 * the easy (scalar or error) case 762 */ 763 p = rvalue( r[ 2 ] , contype , RREQ ); 764 if ( p == NIL ) { 765 return NIL; 766 } 767 /* 768 * since the second pass can't do 769 * long op double or double op long 770 * we may have to do some coercing. 771 */ 772 if ( isa( p , "i" ) && isa( p1 , "d" ) ) { 773 putop( P2SCONV , P2DOUBLE ); 774 } 775 p1 = rvalue( r[ 3 ] , p , RREQ ); 776 if ( isa( p , "d" ) && isa( p1 , "i" ) ) 777 putop( P2SCONV , P2DOUBLE ); 778 putop( relops[ r[0] - T_EQ ] , P2INT ); 779 } 780 # endif PC 781 c = classify(p); 782 c1 = classify(p1); 783 if (nocomp(c) || nocomp(c1)) 784 return (NIL); 785 g = NIL; 786 switch (c) { 787 case TBOOL: 788 case TCHAR: 789 if (c != c1) 790 goto clash; 791 break; 792 case TINT: 793 case TDOUBLE: 794 if (c1 != TINT && c1 != TDOUBLE) 795 goto clash; 796 break; 797 case TSCAL: 798 if (c1 != TSCAL) 799 goto clash; 800 if (scalar(p) != scalar(p1)) 801 goto nonident; 802 break; 803 case TSET: 804 if (c1 != TSET) 805 goto clash; 806 if ( opt( 's' ) && 807 ( ( r[0] == T_LT ) || ( r[0] == T_GT ) ) && 808 ( line != nssetline ) ) { 809 nssetline = line; 810 standard(); 811 error("%s comparison on sets is non-standard" , opname ); 812 } 813 if (p != p1) 814 goto nonident; 815 g = TSET; 816 break; 817 case TREC: 818 if ( c1 != TREC ) { 819 goto clash; 820 } 821 if ( p != p1 ) { 822 goto nonident; 823 } 824 if (r[0] != T_EQ && r[0] != T_NE) { 825 error("%s not allowed on records - only allow = and <>" , opname ); 826 return (NIL); 827 } 828 g = TREC; 829 break; 830 case TPTR: 831 case TNIL: 832 if (c1 != TPTR && c1 != TNIL) 833 goto clash; 834 if (r[0] != T_EQ && r[0] != T_NE) { 835 error("%s not allowed on pointers - only allow = and <>" , opname ); 836 return (NIL); 837 } 838 break; 839 case TSTR: 840 if (c1 != TSTR) 841 goto clash; 842 if (width(p) != width(p1)) { 843 error("Strings not same length in %s comparison", opname); 844 return (NIL); 845 } 846 g = TSTR; 847 break; 848 default: 849 panic("rval2"); 850 } 851 # ifdef OBJ 852 return (gen(g, r[0], width(p), width(p1))); 853 # endif OBJ 854 # ifdef PC 855 return nl + TBOOL; 856 # endif PC 857 clash: 858 error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname); 859 return (NIL); 860 nonident: 861 error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname); 862 return (NIL); 863 864 case T_IN: 865 rt = r[3]; 866 # ifdef OBJ 867 if (rt != NIL && rt[0] == T_CSET) { 868 precset( rt , NIL , &csetd ); 869 p1 = csetd.csettype; 870 if (p1 == NIL) 871 return NIL; 872 postcset( rt, &csetd); 873 } else { 874 p1 = stkrval(r[3], NIL , RREQ ); 875 rt = NIL; 876 } 877 # endif OBJ 878 # ifdef PC 879 if (rt != NIL && rt[0] == T_CSET) { 880 if ( precset( rt , NIL , &csetd ) ) { 881 putleaf( P2ICON , 0 , 0 882 , ADDTYPE( P2FTN | P2INT , P2PTR ) 883 , "_IN" ); 884 } else { 885 putleaf( P2ICON , 0 , 0 886 , ADDTYPE( P2FTN | P2INT , P2PTR ) 887 , "_INCT" ); 888 } 889 p1 = csetd.csettype; 890 if (p1 == NIL) 891 return NIL; 892 } else { 893 putleaf( P2ICON , 0 , 0 894 , ADDTYPE( P2FTN | P2INT , P2PTR ) 895 , "_IN" ); 896 codeoff(); 897 p1 = rvalue(r[3], NIL , LREQ ); 898 codeon(); 899 } 900 # endif PC 901 p = stkrval(r[2], NIL , RREQ ); 902 if (p == NIL || p1 == NIL) 903 return (NIL); 904 if (p1->class != SET) { 905 error("Right operand of 'in' must be a set, not %s", nameof(p1)); 906 return (NIL); 907 } 908 if (incompat(p, p1->type, r[2])) { 909 cerror("Index type clashed with set component type for 'in'"); 910 return (NIL); 911 } 912 setran(p1->type); 913 # ifdef OBJ 914 if (rt == NIL || csetd.comptime) 915 put(4, O_IN, width(p1), set.lwrb, set.uprbp); 916 else 917 put(2, O_INCT, 918 (int)(3 + csetd.singcnt + 2*csetd.paircnt)); 919 # endif OBJ 920 # ifdef PC 921 if ( rt == NIL || rt[0] != T_CSET ) { 922 putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 ); 923 putop( P2LISTOP , P2INT ); 924 putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 ); 925 putop( P2LISTOP , P2INT ); 926 p1 = rvalue( r[3] , NIL , LREQ ); 927 putop( P2LISTOP , P2INT ); 928 } else if ( csetd.comptime ) { 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 postcset( r[3] , &csetd ); 934 putop( P2LISTOP , P2INT ); 935 } else { 936 postcset( r[3] , &csetd ); 937 } 938 putop( P2CALL , P2INT ); 939 # endif PC 940 return (nl+T1BOOL); 941 default: 942 if (r[2] == NIL) 943 return (NIL); 944 switch (r[0]) { 945 default: 946 panic("rval3"); 947 948 949 /* 950 * An octal number 951 */ 952 case T_BINT: 953 f = a8tol(r[2]); 954 goto conint; 955 956 /* 957 * A decimal number 958 */ 959 case T_INT: 960 f = atof(r[2]); 961 conint: 962 if (f > MAXINT || f < MININT) { 963 error("Constant too large for this implementation"); 964 return (NIL); 965 } 966 l = f; 967 if (bytes(l, l) <= 2) { 968 # ifdef OBJ 969 put(2, O_CON2, ( short ) l); 970 # endif OBJ 971 # ifdef PC 972 /* 973 * short constants are ints 974 */ 975 putleaf( P2ICON , l , 0 , P2INT , 0 ); 976 # endif PC 977 return (nl+T2INT); 978 } 979 # ifdef OBJ 980 put(2, O_CON4, l); 981 # endif OBJ 982 # ifdef PC 983 putleaf( P2ICON , l , 0 , P2INT , 0 ); 984 # endif PC 985 return (nl+T4INT); 986 987 /* 988 * A floating point number 989 */ 990 case T_FINT: 991 # ifdef OBJ 992 put(2, O_CON8, atof(r[2])); 993 # endif OBJ 994 # ifdef PC 995 putCON8( atof( r[2] ) ); 996 # endif PC 997 return (nl+TDOUBLE); 998 999 /* 1000 * Constant strings. Note that constant characters 1001 * are constant strings of length one; there is 1002 * no constant string of length one. 1003 */ 1004 case T_STRNG: 1005 cp = r[2]; 1006 if (cp[1] == 0) { 1007 # ifdef OBJ 1008 put(2, O_CONC, cp[0]); 1009 # endif OBJ 1010 # ifdef PC 1011 putleaf( P2ICON , cp[0] , 0 , P2CHAR , 0 ); 1012 # endif PC 1013 return (nl+T1CHAR); 1014 } 1015 goto cstrng; 1016 } 1017 1018 } 1019 } 1020 1021 /* 1022 * Can a class appear 1023 * in a comparison ? 1024 */ 1025 nocomp(c) 1026 int c; 1027 { 1028 1029 switch (c) { 1030 case TREC: 1031 if ( line != reccompline ) { 1032 reccompline = line; 1033 warning(); 1034 if ( opt( 's' ) ) { 1035 standard(); 1036 } 1037 error("record comparison is non-standard"); 1038 } 1039 break; 1040 case TFILE: 1041 case TARY: 1042 error("%ss may not participate in comparisons", clnames[c]); 1043 return (1); 1044 } 1045 return (NIL); 1046 } 1047 1048 /* 1049 * this is sort of like gconst, except it works on expression trees 1050 * rather than declaration trees, and doesn't give error messages for 1051 * non-constant things. 1052 * as a side effect this fills in the con structure that gconst uses. 1053 * this returns TRUE or FALSE. 1054 */ 1055 constval(r) 1056 register int *r; 1057 { 1058 register struct nl *np; 1059 register *cn; 1060 char *cp; 1061 int negd, sgnd; 1062 long ci; 1063 1064 con.ctype = NIL; 1065 cn = r; 1066 negd = sgnd = 0; 1067 loop: 1068 /* 1069 * cn[2] is nil if error recovery generated a T_STRNG 1070 */ 1071 if (cn == NIL || cn[2] == NIL) 1072 return FALSE; 1073 switch (cn[0]) { 1074 default: 1075 return FALSE; 1076 case T_MINUS: 1077 negd = 1 - negd; 1078 /* and fall through */ 1079 case T_PLUS: 1080 sgnd++; 1081 cn = cn[2]; 1082 goto loop; 1083 case T_NIL: 1084 con.cpval = NIL; 1085 con.cival = 0; 1086 con.crval = con.cival; 1087 con.ctype = nl + TNIL; 1088 break; 1089 case T_VAR: 1090 np = lookup(cn[2]); 1091 if (np == NIL || np->class != CONST) { 1092 return FALSE; 1093 } 1094 if ( cn[3] != NIL ) { 1095 return FALSE; 1096 } 1097 con.ctype = np->type; 1098 switch (classify(np->type)) { 1099 case TINT: 1100 con.crval = np->range[0]; 1101 break; 1102 case TDOUBLE: 1103 con.crval = np->real; 1104 break; 1105 case TBOOL: 1106 case TCHAR: 1107 case TSCAL: 1108 con.cival = np->value[0]; 1109 con.crval = con.cival; 1110 break; 1111 case TSTR: 1112 con.cpval = np->ptr[0]; 1113 break; 1114 default: 1115 con.ctype = NIL; 1116 return FALSE; 1117 } 1118 break; 1119 case T_BINT: 1120 con.crval = a8tol(cn[2]); 1121 goto restcon; 1122 case T_INT: 1123 con.crval = atof(cn[2]); 1124 if (con.crval > MAXINT || con.crval < MININT) { 1125 derror("Constant too large for this implementation"); 1126 con.crval = 0; 1127 } 1128 restcon: 1129 ci = con.crval; 1130 #ifndef PI0 1131 if (bytes(ci, ci) <= 2) 1132 con.ctype = nl+T2INT; 1133 else 1134 #endif 1135 con.ctype = nl+T4INT; 1136 break; 1137 case T_FINT: 1138 con.ctype = nl+TDOUBLE; 1139 con.crval = atof(cn[2]); 1140 break; 1141 case T_STRNG: 1142 cp = cn[2]; 1143 if (cp[1] == 0) { 1144 con.ctype = nl+T1CHAR; 1145 con.cival = cp[0]; 1146 con.crval = con.cival; 1147 break; 1148 } 1149 con.ctype = nl+TSTR; 1150 con.cpval = cp; 1151 break; 1152 } 1153 if (sgnd) { 1154 if (isnta(con.ctype, "id")) { 1155 derror("%s constants cannot be signed", nameof(con.ctype)); 1156 return FALSE; 1157 } else if (negd) 1158 con.crval = -con.crval; 1159 } 1160 return TRUE; 1161 } 1162