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