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