![[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.