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

nocomp defined in line 1072; used 2 times
  • in line 810(2)

Defined variables

mathop defined in line 46; used 1 times
nssetline defined in line 28; used 2 times
reccompline defined in line 26; used 2 times
relops defined in line 41; used 1 times
relss defined in line 36; used 1 times
relts defined in line 31; used 1 times
sccsid defined in line 8; never used
setop defined in line 47; used 1 times
Last modified: 1985-06-05
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 5629
Valid CSS Valid XHTML 1.0 Strict