1: /*	@(#)rval.c	2.4	SCCS id keyword	*/
   2: /* Copyright (c) 1979 Regents of the University of California */
   3: #
   4: /*
   5:  * pi - Pascal interpreter code translator
   6:  *
   7:  * Charles Haley, Bill Joy UCB
   8:  * Version 1.2 Novmeber 1978
   9:  */
  10: 
  11: #include "whoami"
  12: #include "0.h"
  13: #include "tree.h"
  14: #include "opcode.h"
  15: 
  16: extern  char *opnames[];
  17: 
  18: short inemptyline = 0;
  19: 
  20: /*
  21:  * Rvalue - an expression.
  22:  *
  23:  * Contype is the type that the caller would prefer, nand is important
  24:  * if constant sets or constant strings are involved, the latter
  25:  * because of string padding.
  26:  */
  27: struct nl *
  28: rvalue(r, contype)
  29:     int *r;
  30:     struct nl *contype;
  31: {
  32:     register struct nl *p, *p1;
  33:     register struct nl *q;
  34:     int c, c1, *rt, w, g;
  35:     char *cp, *cp1, *opname;
  36:     long l;
  37:     double f;
  38: 
  39:     if (r == NIL)
  40:         return (NIL);
  41:     if (nowexp(r))
  42:         return (NIL);
  43:     /*
  44: 	 * Pick up the name of the operation
  45: 	 * for future error messages.
  46: 	 */
  47:     if (r[0] <= T_IN)
  48:         opname = opnames[r[0]];
  49: 
  50:     /*
  51: 	 * The root of the tree tells us what sort of expression we have.
  52: 	 */
  53:     switch (r[0]) {
  54: 
  55:     /*
  56: 	 * The constant nil
  57: 	 */
  58:     case T_NIL:
  59:         put2(O_CON2, 0);
  60:         return (nl+TNIL);
  61: 
  62:     /*
  63: 	 * Function call with arguments.
  64: 	 */
  65:     case T_FCALL:
  66:         return (funccod(r));
  67: 
  68:     case T_VAR:
  69:         p = lookup(r[2]);
  70:         if (p == NIL || p->class == BADUSE)
  71:             return (NIL);
  72:         switch (p->class) {
  73:             case VAR:
  74:                 /*
  75: 				 * If a variable is
  76: 				 * qualified then get
  77: 				 * the rvalue by a
  78: 				 * lvalue and an ind.
  79: 				 */
  80:                 if (r[3] != NIL)
  81:                     goto ind;
  82:                 q = p->type;
  83:                 if (q == NIL)
  84:                     return (NIL);
  85:                 w = width(q);
  86:                 switch (w) {
  87:                     case 8:
  88:                         w = 6;
  89:                     case 4:
  90:                     case 2:
  91:                     case 1:
  92:                         put2(O_RV1 + (w >> 1) | bn << 9, p->value[0]);
  93:                         break;
  94:                     default:
  95:                         put3(O_RV | bn << 9, p->value[0], w);
  96:                 }
  97:                 return (q);
  98: 
  99:             case WITHPTR:
 100:             case REF:
 101:                 /*
 102: 				 * A lvalue for these
 103: 				 * is actually what one
 104: 				 * might consider a rvalue.
 105: 				 */
 106: ind:
 107:                 q = lvalue(r, NOMOD);
 108:                 if (q == NIL)
 109:                     return (NIL);
 110:                 w = width(q);
 111:                 switch (w) {
 112:                     case 8:
 113:                         w = 6;
 114:                     case 4:
 115:                     case 2:
 116:                     case 1:
 117:                         put1(O_IND1 + (w >> 1));
 118:                         break;
 119:                     default:
 120:                         put2(O_IND, w);
 121:                 }
 122:                 return (q);
 123: 
 124:             case CONST:
 125:                 if (r[3] != NIL) {
 126:                     error("%s is a constant and cannot be qualified", r[2]);
 127:                     return (NIL);
 128:                 }
 129:                 q = p->type;
 130:                 if (q == NIL)
 131:                     return (NIL);
 132:                 if (q == nl+TSTR) {
 133:                     /*
 134: 					 * Find the size of the string
 135: 					 * constant if needed.
 136: 					 */
 137:                     cp = p->ptr[0];
 138: cstrng:
 139:                     cp1 = cp;
 140:                     for (c = 0; *cp++; c++)
 141:                         continue;
 142:                     if (contype != NIL && !opt('s')) {
 143:                         if (width(contype) < c && classify(contype) == TSTR) {
 144:                             error("Constant string too long");
 145:                             return (NIL);
 146:                         }
 147:                         c = width(contype);
 148:                     }
 149:                     put( 2 + (sizeof ( char * )/sizeof ( short )) , O_CONG, c, cp1);
 150:                     /*
 151: 					 * Define the string temporarily
 152: 					 * so later people can know its
 153: 					 * width.
 154: 					 * cleaned out by stat.
 155: 					 */
 156:                     q = defnl(0, STR, 0, c);
 157:                     q->type = q;
 158:                     return (q);
 159:                 }
 160:                 if (q == nl+T1CHAR) {
 161:                     put2(O_CONC, p->value[0]);
 162:                     return (q);
 163:                 }
 164:                 /*
 165: 				 * Every other kind of constant here
 166: 				 */
 167:                 switch (width(q)) {
 168:                 case 8:
 169: #ifndef DEBUG
 170:                     put(5, O_CON8, p->real);
 171: #else
 172:                     if (hp21mx) {
 173:                         f = p->real;
 174:                         conv(&f);
 175:                         l = f.plong;
 176:                         put( 3 , O_CON4, l);
 177:                     } else
 178:                         put(5, O_CON8, p->real);
 179: #endif
 180:                     break;
 181:                 case 4:
 182:                     put( 3 , O_CON4, p->range[0]);
 183:                     break;
 184:                 case 2:
 185:                     put2(O_CON2, ( short ) p->range[0]);
 186:                     break;
 187:                 case 1:
 188:                     put2(O_CON1, p->value[0]);
 189:                     break;
 190:                 default:
 191:                     panic("rval");
 192:                 }
 193:                 return (q);
 194: 
 195:             case FUNC:
 196:                 /*
 197: 				 * Function call with no arguments.
 198: 				 */
 199:                 if (r[3]) {
 200:                     error("Can't qualify a function result value");
 201:                     return (NIL);
 202:                 }
 203:                 return (funccod((int *) r));
 204: 
 205:             case TYPE:
 206:                 error("Type names (e.g. %s) allowed only in declarations", p->symbol);
 207:                 return (NIL);
 208: 
 209:             case PROC:
 210:                 error("Procedure %s found where expression required", p->symbol);
 211:                 return (NIL);
 212:             default:
 213:                 panic("rvid");
 214:         }
 215:     /*
 216: 	 * Constant sets
 217: 	 */
 218:     case T_CSET:
 219:         return (cset(r, contype, NIL));
 220: 
 221:     /*
 222: 	 * Unary plus and minus
 223: 	 */
 224:     case T_PLUS:
 225:     case T_MINUS:
 226:         q = rvalue(r[2], NIL);
 227:         if (q == NIL)
 228:             return (NIL);
 229:         if (isnta(q, "id")) {
 230:             error("Operand of %s must be integer or real, not %s", opname, nameof(q));
 231:             return (NIL);
 232:         }
 233:         if (r[0] == T_MINUS) {
 234:             put1(O_NEG2 + (width(q) >> 2));
 235:             return (isa(q, "d") ? q : nl+T4INT);
 236:         }
 237:         return (q);
 238: 
 239:     case T_NOT:
 240:         q = rvalue(r[2], NIL);
 241:         if (q == NIL)
 242:             return (NIL);
 243:         if (isnta(q, "b")) {
 244:             error("not must operate on a Boolean, not %s", nameof(q));
 245:             return (NIL);
 246:         }
 247:         put1(O_NOT);
 248:         return (nl+T1BOOL);
 249: 
 250:     case T_AND:
 251:     case T_OR:
 252:         p = rvalue(r[2], NIL);
 253:         p1 = rvalue(r[3], NIL);
 254:         if (p == NIL || p1 == NIL)
 255:             return (NIL);
 256:         if (isnta(p, "b")) {
 257:             error("Left operand of %s must be Boolean, not %s", opname, nameof(p));
 258:             return (NIL);
 259:         }
 260:         if (isnta(p1, "b")) {
 261:             error("Right operand of %s must be Boolean, not %s", opname, nameof(p1));
 262:             return (NIL);
 263:         }
 264:         put1(r[0] == T_AND ? O_AND : O_OR);
 265:         return (nl+T1BOOL);
 266: 
 267:     case T_DIVD:
 268:         p = rvalue(r[2], NIL);
 269:         p1 = rvalue(r[3], NIL);
 270:         if (p == NIL || p1 == NIL)
 271:             return (NIL);
 272:         if (isnta(p, "id")) {
 273:             error("Left operand of / must be integer or real, not %s", nameof(p));
 274:             return (NIL);
 275:         }
 276:         if (isnta(p1, "id")) {
 277:             error("Right operand of / must be integer or real, not %s", nameof(p1));
 278:             return (NIL);
 279:         }
 280:         return (gen(NIL, r[0], width(p), width(p1)));
 281: 
 282:     case T_MULT:
 283:     case T_SUB:
 284:     case T_ADD:
 285:         /*
 286: 		 * If the context hasn't told us
 287: 		 * the type and a constant set is
 288: 		 * present on the left we need to infer
 289: 		 * the type from the right if possible
 290: 		 * before generating left side code.
 291: 		 */
 292:         if (contype == NIL && (rt = r[2]) != NIL && rt[1] == SAWCON) {
 293:             codeoff();
 294:             contype = rvalue(r[3], NIL);
 295:             codeon();
 296:             if (contype == NIL)
 297:                 return (NIL);
 298:         }
 299:         p = rvalue(r[2], contype);
 300:         p1 = rvalue(r[3], p);
 301:         if (p == NIL || p1 == NIL)
 302:             return (NIL);
 303:         if (isa(p, "id") && isa(p1, "id"))
 304:             return (gen(NIL, r[0], width(p), width(p1)));
 305:         if (isa(p, "t") && isa(p1, "t")) {
 306:             if (p != p1) {
 307:                 error("Set types of operands of %s must be identical", opname);
 308:                 return (NIL);
 309:             }
 310:             gen(TSET, r[0], width(p), 0);
 311:             /*
 312: 			 * Note that set was filled in by the call
 313: 			 * to width above.
 314: 			 */
 315:             if (r[0] == T_SUB)
 316:                 put2(NIL, 0177777 << ((set.uprbp & 017) + 1));
 317:             return (p);
 318:         }
 319:         if (isnta(p, "idt")) {
 320:             error("Left operand of %s must be integer, real or set, not %s", opname, nameof(p));
 321:             return (NIL);
 322:         }
 323:         if (isnta(p1, "idt")) {
 324:             error("Right operand of %s must be integer, real or set, not %s", opname, nameof(p1));
 325:             return (NIL);
 326:         }
 327:         error("Cannot mix sets with integers and reals as operands of %s", opname);
 328:         return (NIL);
 329: 
 330:     case T_MOD:
 331:     case T_DIV:
 332:         p = rvalue(r[2], NIL);
 333:         p1 = rvalue(r[3], NIL);
 334:         if (p == NIL || p1 == NIL)
 335:             return (NIL);
 336:         if (isnta(p, "i")) {
 337:             error("Left operand of %s must be integer, not %s", opname, nameof(p));
 338:             return (NIL);
 339:         }
 340:         if (isnta(p1, "i")) {
 341:             error("Right operand of %s must be integer, not %s", opname, nameof(p1));
 342:             return (NIL);
 343:         }
 344:         return (gen(NIL, r[0], width(p), width(p1)));
 345: 
 346:     case T_EQ:
 347:     case T_NE:
 348:     case T_GE:
 349:     case T_LE:
 350:     case T_GT:
 351:     case T_LT:
 352:         /*
 353: 		 * Since there can be no, a priori, knowledge
 354: 		 * of the context type should a constant string
 355: 		 * or set arise, we must poke around to find such
 356: 		 * a type if possible.  Since constant strings can
 357: 		 * always masquerade as identifiers, this is always
 358: 		 * necessary.
 359: 		 */
 360:         codeoff();
 361:         p1 = rvalue(r[3], NIL);
 362:         codeon();
 363:         if (p1 == NIL)
 364:             return (NIL);
 365:         contype = p1;
 366:         if (p1 == nl+TSET || p1->class == STR) {
 367:             /*
 368: 			 * For constant strings we want
 369: 			 * the longest type so as to be
 370: 			 * able to do padding (more importantly
 371: 			 * avoiding truncation). For clarity,
 372: 			 * we get this length here.
 373: 			 */
 374:             codeoff();
 375:             p = rvalue(r[2], NIL);
 376:             codeon();
 377:             if (p == NIL)
 378:                 return (NIL);
 379:             if (p1 == nl+TSET || width(p) > width(p1))
 380:                 contype = p;
 381:         }
 382:         /*
 383: 		 * Now we generate code for
 384: 		 * the operands of the relational
 385: 		 * operation.
 386: 		 */
 387:         p = rvalue(r[2], contype);
 388:         if (p == NIL)
 389:             return (NIL);
 390:         p1 = rvalue(r[3], p);
 391:         if (p1 == NIL)
 392:             return (NIL);
 393:         c = classify(p);
 394:         c1 = classify(p1);
 395:         if (nocomp(c) || nocomp(c1))
 396:             return (NIL);
 397:         g = NIL;
 398:         switch (c) {
 399:             case TBOOL:
 400:             case TCHAR:
 401:                 if (c != c1)
 402:                     goto clash;
 403:                 break;
 404:             case TINT:
 405:             case TDOUBLE:
 406:                 if (c1 != TINT && c1 != TDOUBLE)
 407:                     goto clash;
 408:                 break;
 409:             case TSCAL:
 410:                 if (c1 != TSCAL)
 411:                     goto clash;
 412:                 if (scalar(p) != scalar(p1))
 413:                     goto nonident;
 414:                 break;
 415:             case TSET:
 416:                 if (c1 != TSET)
 417:                     goto clash;
 418:                 if (p != p1)
 419:                     goto nonident;
 420:                 g = TSET;
 421:                 break;
 422:             case TPTR:
 423:             case TNIL:
 424:                 if (c1 != TPTR && c1 != TNIL)
 425:                     goto clash;
 426:                 if (r[0] != T_EQ && r[0] != T_NE) {
 427:                     error("%s not allowed on pointers - only allow = and <>" , opname );
 428:                     return (NIL);
 429:                 }
 430:                 break;
 431:             case TSTR:
 432:                 if (c1 != TSTR)
 433:                     goto clash;
 434:                 if (width(p) != width(p1)) {
 435:                     error("Strings not same length in %s comparison", opname);
 436:                     return (NIL);
 437:                 }
 438:                 g = TSTR;
 439:                 break;
 440:             default:
 441:                 panic("rval2");
 442:         }
 443:         return (gen(g, r[0], width(p), width(p1)));
 444: clash:
 445:         error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname);
 446:         return (NIL);
 447: nonident:
 448:         error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname);
 449:         return (NIL);
 450: 
 451:     case T_IN:
 452:         rt = r[3];
 453:         if (rt != NIL && rt[0] == T_CSET)
 454:             p1 = cset(rt, NLNIL, 1);
 455:         else {
 456:             p1 = rvalue(r[3], NIL);
 457:             rt = NIL;
 458:         }
 459:         if (p1 == nl+TSET) {
 460:             if ( line != inemptyline ) {
 461:                 inemptyline = line;
 462:                 warning();
 463:                 error("... in [] makes little sense, since it is always false!");
 464:             }
 465:             put2(O_CON1, 0);
 466:             return (nl+T1BOOL);
 467:         }
 468:         p = rvalue(r[2], NIL);
 469:         if (p == NIL || p1 == NIL)
 470:             return (NIL);
 471:         if (p1->class != SET) {
 472:             error("Right operand of 'in' must be a set, not %s", nameof(p1));
 473:             return (NIL);
 474:         }
 475:         if (incompat(p, p1->type, r[2])) {
 476:             cerror("Index type clashed with set component type for 'in'");
 477:             return (NIL);
 478:         }
 479:         convert(p, nl+T2INT);
 480:         setran(p1->type);
 481:         if (rt == NIL)
 482:             put4(O_IN, width(p1), set.lwrb, set.uprbp);
 483:         else
 484:             put1(O_INCT);
 485:         return (nl+T1BOOL);
 486: 
 487:     default:
 488:         if (r[2] == NIL)
 489:             return (NIL);
 490:         switch (r[0]) {
 491:         default:
 492:             panic("rval3");
 493: 
 494: 
 495:         /*
 496: 		 * An octal number
 497: 		 */
 498:         case T_BINT:
 499:             f = a8tol(r[2]);
 500:             goto conint;
 501: 
 502:         /*
 503: 		 * A decimal number
 504: 		 */
 505:         case T_INT:
 506:             f = atof(r[2]);
 507: conint:
 508:             if (f > MAXINT || f < MININT) {
 509:                 error("Constant too large for this implementation");
 510:                 return (NIL);
 511:             }
 512:             l = f;
 513:             if (bytes(l, l) <= 2) {
 514:                 put2(O_CON2, ( short ) l);
 515:                 return (nl+T2INT);
 516:             }
 517:             put( 3 , O_CON4, l);
 518:             return (nl+T4INT);
 519: 
 520:         /*
 521: 		 * A floating point number
 522: 		 */
 523:         case T_FINT:
 524:             put(5, O_CON8, atof(r[2]));
 525:             return (nl+TDOUBLE);
 526: 
 527:         /*
 528: 		 * Constant strings.  Note that constant characters
 529: 		 * are constant strings of length one; there is
 530: 		 * no constant string of length one.
 531: 		 */
 532:         case T_STRNG:
 533:             cp = r[2];
 534:             if (cp[1] == 0) {
 535:                 put2(O_CONC, cp[0]);
 536:                 return (nl+T1CHAR);
 537:             }
 538:             goto cstrng;
 539:         }
 540: 
 541:     }
 542: }
 543: 
 544: /*
 545:  * Can a class appear
 546:  * in a comparison ?
 547:  */
 548: nocomp(c)
 549:     int c;
 550: {
 551: 
 552:     switch (c) {
 553:         case TFILE:
 554:         case TARY:
 555:         case TREC:
 556:             error("%ss may not participate in comparisons", clnames[c]);
 557:             return (1);
 558:     }
 559:     return (NIL);
 560: }

Defined functions

nocomp defined in line 548; used 2 times
  • in line 395(2)

Defined variables

inemptyline defined in line 18; used 2 times
Last modified: 1983-03-17
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 3269
Valid CSS Valid XHTML 1.0 Strict