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