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