1 /*-
2 * Copyright (c) 1980, 1993
3 * The Regents of the University of California. All rights reserved.
4 *
5 * %sccs.include.redist.c%
6 */
7
8 #ifndef lint
9 static char sccsid[] = "@(#)rval.c 8.1 (Berkeley) 06/06/93";
10 #endif /* not lint */
11
12 #include "whoami.h"
13 #include "0.h"
14 #include "tree.h"
15 #include "opcode.h"
16 #include "objfmt.h"
17 #ifdef PC
18 # include "pc.h"
19 # include <pcc.h>
20 #endif PC
21 #include "tmps.h"
22 #include "tree_ty.h"
23
24 extern char *opnames[];
25
26 /* line number of the last record comparison warning */
27 short reccompline = 0;
28 /* line number of the last non-standard set comparison */
29 short nssetline = 0;
30
31 #ifdef PC
32 char *relts[] = {
33 "_RELEQ" , "_RELNE" ,
34 "_RELTLT" , "_RELTGT" ,
35 "_RELTLE" , "_RELTGE"
36 };
37 char *relss[] = {
38 "_RELEQ" , "_RELNE" ,
39 "_RELSLT" , "_RELSGT" ,
40 "_RELSLE" , "_RELSGE"
41 };
42 long relops[] = {
43 PCC_EQ , PCC_NE ,
44 PCC_LT , PCC_GT ,
45 PCC_LE , PCC_GE
46 };
47 long mathop[] = { PCC_MUL , PCC_PLUS , PCC_MINUS };
48 char *setop[] = { "_MULT" , "_ADDT" , "_SUBT" };
49 #endif PC
50 /*
51 * Rvalue - an expression.
52 *
53 * Contype is the type that the caller would prefer, nand is important
54 * if constant strings are involved, because of string padding.
55 * required is a flag whether an lvalue or an rvalue is required.
56 * only VARs and structured things can have gt their lvalue this way.
57 */
58 /*ARGSUSED*/
59 struct nl *
rvalue(r,contype,required)60 rvalue(r, contype , required )
61 struct tnode *r;
62 struct nl *contype;
63 int required;
64 {
65 register struct nl *p, *p1;
66 register struct nl *q;
67 int c, c1, w;
68 #ifdef OBJ
69 int g;
70 #endif
71 struct tnode *rt;
72 char *cp, *cp1, *opname;
73 long l;
74 union
75 {
76 long plong[2];
77 double pdouble;
78 }f;
79 extern int flagwas;
80 struct csetstr csetd;
81 # ifdef PC
82 struct nl *rettype;
83 long ctype;
84 struct nl *tempnlp;
85 # endif PC
86
87 if (r == TR_NIL)
88 return (NLNIL);
89 if (nowexp(r))
90 return (NLNIL);
91 /*
92 * Pick up the name of the operation
93 * for future error messages.
94 */
95 if (r->tag <= T_IN)
96 opname = opnames[r->tag];
97
98 /*
99 * The root of the tree tells us what sort of expression we have.
100 */
101 switch (r->tag) {
102
103 /*
104 * The constant nil
105 */
106 case T_NIL:
107 # ifdef OBJ
108 (void) put(2, O_CON2, 0);
109 # endif OBJ
110 # ifdef PC
111 putleaf( PCC_ICON , 0 , 0 , PCCTM_PTR|PCCT_UNDEF , (char *) 0 );
112 # endif PC
113 return (nl+TNIL);
114
115 /*
116 * Function call with arguments.
117 */
118 case T_FCALL:
119 # ifdef OBJ
120 return (funccod(r));
121 # endif OBJ
122 # ifdef PC
123 return (pcfunccod( r ));
124 # endif PC
125
126 case T_VAR:
127 p = lookup(r->var_node.cptr);
128 if (p == NLNIL || p->class == BADUSE)
129 return (NLNIL);
130 switch (p->class) {
131 case VAR:
132 /*
133 * If a variable is
134 * qualified then get
135 * the rvalue by a
136 * lvalue and an ind.
137 */
138 if (r->var_node.qual != TR_NIL)
139 goto ind;
140 q = p->type;
141 if (q == NIL)
142 return (NLNIL);
143 # ifdef OBJ
144 w = width(q);
145 switch (w) {
146 case 8:
147 (void) put(2, O_RV8 | bn << 8+INDX,
148 (int)p->value[0]);
149 break;
150 case 4:
151 (void) put(2, O_RV4 | bn << 8+INDX,
152 (int)p->value[0]);
153 break;
154 case 2:
155 (void) put(2, O_RV2 | bn << 8+INDX,
156 (int)p->value[0]);
157 break;
158 case 1:
159 (void) put(2, O_RV1 | bn << 8+INDX,
160 (int)p->value[0]);
161 break;
162 default:
163 (void) put(3, O_RV | bn << 8+INDX,
164 (int)p->value[0], w);
165 }
166 # endif OBJ
167 # ifdef PC
168 if ( required == RREQ ) {
169 putRV( p -> symbol , bn , p -> value[0] ,
170 p -> extra_flags , p2type( q ) );
171 } else {
172 putLV( p -> symbol , bn , p -> value[0] ,
173 p -> extra_flags , p2type( q ) );
174 }
175 # endif PC
176 return (q);
177
178 case WITHPTR:
179 case REF:
180 /*
181 * A lvalue for these
182 * is actually what one
183 * might consider a rvalue.
184 */
185 ind:
186 q = lvalue(r, NOFLAGS , LREQ );
187 if (q == NIL)
188 return (NLNIL);
189 # ifdef OBJ
190 w = width(q);
191 switch (w) {
192 case 8:
193 (void) put(1, O_IND8);
194 break;
195 case 4:
196 (void) put(1, O_IND4);
197 break;
198 case 2:
199 (void) put(1, O_IND2);
200 break;
201 case 1:
202 (void) put(1, O_IND1);
203 break;
204 default:
205 (void) put(2, O_IND, w);
206 }
207 # endif OBJ
208 # ifdef PC
209 if ( required == RREQ ) {
210 putop( PCCOM_UNARY PCC_MUL , p2type( q ) );
211 }
212 # endif PC
213 return (q);
214
215 case CONST:
216 if (r->var_node.qual != TR_NIL) {
217 error("%s is a constant and cannot be qualified", r->var_node.cptr);
218 return (NLNIL);
219 }
220 q = p->type;
221 if (q == NLNIL)
222 return (NLNIL);
223 if (q == nl+TSTR) {
224 /*
225 * Find the size of the string
226 * constant if needed.
227 */
228 cp = (char *) p->ptr[0];
229 cstrng:
230 cp1 = cp;
231 for (c = 0; *cp++; c++)
232 continue;
233 w = c;
234 if (contype != NIL && !opt('s')) {
235 if (width(contype) < c && classify(contype) == TSTR) {
236 error("Constant string too long");
237 return (NLNIL);
238 }
239 w = width(contype);
240 }
241 # ifdef OBJ
242 (void) put(2, O_CONG, w);
243 putstr(cp1, w - c);
244 # endif OBJ
245 # ifdef PC
246 putCONG( cp1 , w , required );
247 # endif PC
248 /*
249 * Define the string temporarily
250 * so later people can know its
251 * width.
252 * cleaned out by stat.
253 */
254 q = defnl((char *) 0, STR, NLNIL, w);
255 q->type = q;
256 return (q);
257 }
258 if (q == nl+T1CHAR) {
259 # ifdef OBJ
260 (void) put(2, O_CONC, (int)p->value[0]);
261 # endif OBJ
262 # ifdef PC
263 putleaf( PCC_ICON , p -> value[0] , 0
264 , PCCT_CHAR , (char *) 0 );
265 # endif PC
266 return (q);
267 }
268 /*
269 * Every other kind of constant here
270 */
271 switch (width(q)) {
272 case 8:
273 #ifndef DEBUG
274 # ifdef OBJ
275 (void) put(2, O_CON8, p->real);
276 # endif OBJ
277 # ifdef PC
278 putCON8( p -> real );
279 # endif PC
280 #else
281 if (hp21mx) {
282 f.pdouble = p->real;
283 conv((int *) (&f.pdouble));
284 l = f.plong[1];
285 (void) put(2, O_CON4, l);
286 } else
287 # ifdef OBJ
288 (void) put(2, O_CON8, p->real);
289 # endif OBJ
290 # ifdef PC
291 putCON8( p -> real );
292 # endif PC
293 #endif
294 break;
295 case 4:
296 # ifdef OBJ
297 (void) put(2, O_CON4, p->range[0]);
298 # endif OBJ
299 # ifdef PC
300 putleaf( PCC_ICON , (int) p->range[0] , 0
301 , PCCT_INT , (char *) 0 );
302 # endif PC
303 break;
304 case 2:
305 # ifdef OBJ
306 (void) put(2, O_CON2, (short)p->range[0]);
307 # endif OBJ
308 # ifdef PC
309 putleaf( PCC_ICON , (short) p -> range[0]
310 , 0 , PCCT_SHORT , (char *) 0 );
311 # endif PC
312 break;
313 case 1:
314 # ifdef OBJ
315 (void) put(2, O_CON1, p->value[0]);
316 # endif OBJ
317 # ifdef PC
318 putleaf( PCC_ICON , p -> value[0] , 0
319 , PCCT_CHAR , (char *) 0 );
320 # endif PC
321 break;
322 default:
323 panic("rval");
324 }
325 return (q);
326
327 case FUNC:
328 case FFUNC:
329 /*
330 * Function call with no arguments.
331 */
332 if (r->var_node.qual != TR_NIL) {
333 error("Can't qualify a function result value");
334 return (NLNIL);
335 }
336 # ifdef OBJ
337 return (funccod(r));
338 # endif OBJ
339 # ifdef PC
340 return (pcfunccod( r ));
341 # endif PC
342
343 case TYPE:
344 error("Type names (e.g. %s) allowed only in declarations", p->symbol);
345 return (NLNIL);
346
347 case PROC:
348 case FPROC:
349 error("Procedure %s found where expression required", p->symbol);
350 return (NLNIL);
351 default:
352 panic("rvid");
353 }
354 /*
355 * Constant sets
356 */
357 case T_CSET:
358 # ifdef OBJ
359 if ( precset( r , contype , &csetd ) ) {
360 if ( csetd.csettype == NIL ) {
361 return (NLNIL);
362 }
363 postcset( r , &csetd );
364 } else {
365 (void) put( 2, O_PUSH, -lwidth(csetd.csettype));
366 postcset( r , &csetd );
367 setran( ( csetd.csettype ) -> type );
368 (void) put( 2, O_CON24, set.uprbp);
369 (void) put( 2, O_CON24, set.lwrb);
370 (void) put( 2, O_CTTOT,
371 (int)(4 + csetd.singcnt + 2 * csetd.paircnt));
372 }
373 return csetd.csettype;
374 # endif OBJ
375 # ifdef PC
376 if ( precset( r , contype , &csetd ) ) {
377 if ( csetd.csettype == NIL ) {
378 return (NLNIL);
379 }
380 postcset( r , &csetd );
381 } else {
382 putleaf( PCC_ICON , 0 , 0
383 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
384 , "_CTTOT" );
385 /*
386 * allocate a temporary and use it
387 */
388 tempnlp = tmpalloc(lwidth(csetd.csettype),
389 csetd.csettype, NOREG);
390 putLV( (char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
391 tempnlp -> extra_flags , PCCTM_PTR|PCCT_STRTY );
392 setran( ( csetd.csettype ) -> type );
393 putleaf( PCC_ICON , set.lwrb , 0 , PCCT_INT , (char *) 0 );
394 putop( PCC_CM , PCCT_INT );
395 putleaf( PCC_ICON , set.uprbp , 0 , PCCT_INT , (char *) 0 );
396 putop( PCC_CM , PCCT_INT );
397 postcset( r , &csetd );
398 putop( PCC_CALL , PCCT_INT );
399 }
400 return csetd.csettype;
401 # endif PC
402
403 /*
404 * Unary plus and minus
405 */
406 case T_PLUS:
407 case T_MINUS:
408 q = rvalue(r->un_expr.expr, NLNIL , RREQ );
409 if (q == NLNIL)
410 return (NLNIL);
411 if (isnta(q, "id")) {
412 error("Operand of %s must be integer or real, not %s", opname, nameof(q));
413 return (NLNIL);
414 }
415 if (r->tag == T_MINUS) {
416 # ifdef OBJ
417 (void) put(1, O_NEG2 + (width(q) >> 2));
418 return (isa(q, "d") ? q : nl+T4INT);
419 # endif OBJ
420 # ifdef PC
421 if (isa(q, "i")) {
422 sconv(p2type(q), PCCT_INT);
423 putop( PCCOM_UNARY PCC_MINUS, PCCT_INT);
424 return nl+T4INT;
425 }
426 putop( PCCOM_UNARY PCC_MINUS, PCCT_DOUBLE);
427 return nl+TDOUBLE;
428 # endif PC
429 }
430 return (q);
431
432 case T_NOT:
433 q = rvalue(r->un_expr.expr, NLNIL , RREQ );
434 if (q == NLNIL)
435 return (NLNIL);
436 if (isnta(q, "b")) {
437 error("not must operate on a Boolean, not %s", nameof(q));
438 return (NLNIL);
439 }
440 # ifdef OBJ
441 (void) put(1, O_NOT);
442 # endif OBJ
443 # ifdef PC
444 sconv(p2type(q), PCCT_INT);
445 putop( PCC_NOT , PCCT_INT);
446 sconv(PCCT_INT, p2type(q));
447 # endif PC
448 return (nl+T1BOOL);
449
450 case T_AND:
451 case T_OR:
452 p = rvalue(r->expr_node.lhs, NLNIL , RREQ );
453 # ifdef PC
454 sconv(p2type(p),PCCT_INT);
455 # endif PC
456 p1 = rvalue(r->expr_node.rhs, NLNIL , RREQ );
457 # ifdef PC
458 sconv(p2type(p1),PCCT_INT);
459 # endif PC
460 if (p == NLNIL || p1 == NLNIL)
461 return (NLNIL);
462 if (isnta(p, "b")) {
463 error("Left operand of %s must be Boolean, not %s", opname, nameof(p));
464 return (NLNIL);
465 }
466 if (isnta(p1, "b")) {
467 error("Right operand of %s must be Boolean, not %s", opname, nameof(p1));
468 return (NLNIL);
469 }
470 # ifdef OBJ
471 (void) put(1, r->tag == T_AND ? O_AND : O_OR);
472 # endif OBJ
473 # ifdef PC
474 /*
475 * note the use of & and | rather than && and ||
476 * to force evaluation of all the expressions.
477 */
478 putop( r->tag == T_AND ? PCC_AND : PCC_OR , PCCT_INT );
479 sconv(PCCT_INT, p2type(p));
480 # endif PC
481 return (nl+T1BOOL);
482
483 case T_DIVD:
484 # ifdef OBJ
485 p = rvalue(r->expr_node.lhs, NLNIL , RREQ );
486 p1 = rvalue(r->expr_node.rhs, NLNIL , RREQ );
487 # endif OBJ
488 # ifdef PC
489 /*
490 * force these to be doubles for the divide
491 */
492 p = rvalue( r->expr_node.lhs , NLNIL , RREQ );
493 sconv(p2type(p), PCCT_DOUBLE);
494 p1 = rvalue( r->expr_node.rhs , NLNIL , RREQ );
495 sconv(p2type(p1), PCCT_DOUBLE);
496 # endif PC
497 if (p == NLNIL || p1 == NLNIL)
498 return (NLNIL);
499 if (isnta(p, "id")) {
500 error("Left operand of / must be integer or real, not %s", nameof(p));
501 return (NLNIL);
502 }
503 if (isnta(p1, "id")) {
504 error("Right operand of / must be integer or real, not %s", nameof(p1));
505 return (NLNIL);
506 }
507 # ifdef OBJ
508 return gen(NIL, r->tag, width(p), width(p1));
509 # endif OBJ
510 # ifdef PC
511 putop( PCC_DIV , PCCT_DOUBLE );
512 return nl + TDOUBLE;
513 # endif PC
514
515 case T_MULT:
516 case T_ADD:
517 case T_SUB:
518 # ifdef OBJ
519 /*
520 * get the type of the right hand side.
521 * if it turns out to be a set,
522 * use that type when getting
523 * the type of the left hand side.
524 * and then use the type of the left hand side
525 * when generating code.
526 * this will correctly decide the type of any
527 * empty sets in the tree, since if the empty set
528 * is on the left hand side it will inherit
529 * the type of the right hand side,
530 * and if it's on the right hand side, its type (intset)
531 * will be overridden by the type of the left hand side.
532 * this is an awful lot of tree traversing,
533 * but it works.
534 */
535 codeoff();
536 p1 = rvalue( r->expr_node.rhs , NLNIL , RREQ );
537 codeon();
538 if ( p1 == NLNIL ) {
539 return NLNIL;
540 }
541 if (isa(p1, "t")) {
542 codeoff();
543 contype = rvalue(r->expr_node.lhs, p1, RREQ);
544 codeon();
545 if (contype == NLNIL) {
546 return NLNIL;
547 }
548 }
549 p = rvalue( r->expr_node.lhs , contype , RREQ );
550 p1 = rvalue( r->expr_node.rhs , p , RREQ );
551 if ( p == NLNIL || p1 == NLNIL )
552 return NLNIL;
553 if (isa(p, "id") && isa(p1, "id"))
554 return (gen(NIL, r->tag, width(p), width(p1)));
555 if (isa(p, "t") && isa(p1, "t")) {
556 if (p != p1) {
557 error("Set types of operands of %s must be identical", opname);
558 return (NLNIL);
559 }
560 (void) gen(TSET, r->tag, width(p), 0);
561 return (p);
562 }
563 # endif OBJ
564 # ifdef PC
565 /*
566 * the second pass can't do
567 * long op double or double op long
568 * so we have to know the type of both operands.
569 * also, see the note for obj above on determining
570 * the type of empty sets.
571 */
572 codeoff();
573 p1 = rvalue(r->expr_node.rhs, NLNIL, RREQ);
574 codeon();
575 if ( isa( p1 , "id" ) ) {
576 p = rvalue( r->expr_node.lhs , contype , RREQ );
577 if ( ( p == NLNIL ) || ( p1 == NLNIL ) ) {
578 return NLNIL;
579 }
580 tuac(p, p1, &rettype, (int *) (&ctype));
581 p1 = rvalue( r->expr_node.rhs , contype , RREQ );
582 tuac(p1, p, &rettype, (int *) (&ctype));
583 if ( isa( p , "id" ) ) {
584 putop( (int) mathop[r->tag - T_MULT], (int) ctype);
585 return rettype;
586 }
587 }
588 if ( isa( p1 , "t" ) ) {
589 putleaf( PCC_ICON , 0 , 0
590 , PCCM_ADDTYPE( PCCM_ADDTYPE( PCCTM_PTR | PCCT_STRTY , PCCTM_FTN )
591 , PCCTM_PTR )
592 , setop[ r->tag - T_MULT ] );
593 codeoff();
594 contype = rvalue( r->expr_node.lhs, p1 , LREQ );
595 codeon();
596 if ( contype == NLNIL ) {
597 return NLNIL;
598 }
599 /*
600 * allocate a temporary and use it
601 */
602 tempnlp = tmpalloc(lwidth(contype), contype, NOREG);
603 putLV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
604 tempnlp -> extra_flags , PCCTM_PTR|PCCT_STRTY );
605 p = rvalue( r->expr_node.lhs , contype , LREQ );
606 if ( isa( p , "t" ) ) {
607 putop( PCC_CM , PCCT_INT );
608 if ( p == NLNIL || p1 == NLNIL ) {
609 return NLNIL;
610 }
611 p1 = rvalue( r->expr_node.rhs , p , LREQ );
612 if ( p != p1 ) {
613 error("Set types of operands of %s must be identical", opname);
614 return NLNIL;
615 }
616 putop( PCC_CM , PCCT_INT );
617 putleaf( PCC_ICON , (int) (lwidth(p1)) / sizeof( long ) , 0
618 , PCCT_INT , (char *) 0 );
619 putop( PCC_CM , PCCT_INT );
620 putop( PCC_CALL , PCCTM_PTR | PCCT_STRTY );
621 return p;
622 }
623 }
624 if ( isnta( p1 , "idt" ) ) {
625 /*
626 * find type of left operand for error message.
627 */
628 p = rvalue( r->expr_node.lhs , contype , RREQ );
629 }
630 /*
631 * don't give spurious error messages.
632 */
633 if ( p == NLNIL || p1 == NLNIL ) {
634 return NLNIL;
635 }
636 # endif PC
637 if (isnta(p, "idt")) {
638 error("Left operand of %s must be integer, real or set, not %s", opname, nameof(p));
639 return (NLNIL);
640 }
641 if (isnta(p1, "idt")) {
642 error("Right operand of %s must be integer, real or set, not %s", opname, nameof(p1));
643 return (NLNIL);
644 }
645 error("Cannot mix sets with integers and reals as operands of %s", opname);
646 return (NLNIL);
647
648 case T_MOD:
649 case T_DIV:
650 p = rvalue(r->expr_node.lhs, NLNIL , RREQ );
651 # ifdef PC
652 sconv(p2type(p), PCCT_INT);
653 # ifdef tahoe
654 /* prepare for ediv workaround, see below. */
655 if (r->tag == T_MOD) {
656 (void) rvalue(r->expr_node.lhs, NLNIL, RREQ);
657 sconv(p2type(p), PCCT_INT);
658 }
659 # endif tahoe
660 # endif PC
661 p1 = rvalue(r->expr_node.rhs, NLNIL , RREQ );
662 # ifdef PC
663 sconv(p2type(p1), PCCT_INT);
664 # endif PC
665 if (p == NLNIL || p1 == NLNIL)
666 return (NLNIL);
667 if (isnta(p, "i")) {
668 error("Left operand of %s must be integer, not %s", opname, nameof(p));
669 return (NLNIL);
670 }
671 if (isnta(p1, "i")) {
672 error("Right operand of %s must be integer, not %s", opname, nameof(p1));
673 return (NLNIL);
674 }
675 # ifdef OBJ
676 return (gen(NIL, r->tag, width(p), width(p1)));
677 # endif OBJ
678 # ifdef PC
679 # ifndef tahoe
680 putop( r->tag == T_DIV ? PCC_DIV : PCC_MOD , PCCT_INT );
681 return ( nl + T4INT );
682 # else tahoe
683 putop( PCC_DIV , PCCT_INT );
684 if (r->tag == T_MOD) {
685 /*
686 * avoid f1 bug: PCC_MOD would generate an 'ediv',
687 * which would reuire too many registers to evaluate
688 * things like
689 * var i:boolean;j:integer; i := (j+1) = (j mod 2);
690 * so, instead of
691 * PCC_MOD
692 * / \
693 * p p1
694 * we put
695 * PCC_MINUS
696 * / \
697 * p PCC_MUL
698 * / \
699 * PCC_DIV p1
700 * / \
701 * p p1
702 *
703 * we already have put p, p, p1, PCC_DIV. and now...
704 */
705 rvalue(r->expr_node.rhs, NLNIL , RREQ );
706 sconv(p2type(p1), PCCT_INT);
707 putop( PCC_MUL, PCCT_INT );
708 putop( PCC_MINUS, PCCT_INT );
709 }
710 return ( nl + T4INT );
711 # endif tahoe
712 # endif PC
713
714 case T_EQ:
715 case T_NE:
716 case T_LT:
717 case T_GT:
718 case T_LE:
719 case T_GE:
720 /*
721 * Since there can be no, a priori, knowledge
722 * of the context type should a constant string
723 * or set arise, we must poke around to find such
724 * a type if possible. Since constant strings can
725 * always masquerade as identifiers, this is always
726 * necessary.
727 * see the note in the obj section of case T_MULT above
728 * for the determination of the base type of empty sets.
729 */
730 codeoff();
731 p1 = rvalue(r->expr_node.rhs, NLNIL , RREQ );
732 codeon();
733 if (p1 == NLNIL)
734 return (NLNIL);
735 contype = p1;
736 # ifdef OBJ
737 if (p1->class == STR) {
738 /*
739 * For constant strings we want
740 * the longest type so as to be
741 * able to do padding (more importantly
742 * avoiding truncation). For clarity,
743 * we get this length here.
744 */
745 codeoff();
746 p = rvalue(r->expr_node.lhs, NLNIL , RREQ );
747 codeon();
748 if (p == NLNIL)
749 return (NLNIL);
750 if (width(p) > width(p1))
751 contype = p;
752 }
753 if (isa(p1, "t")) {
754 codeoff();
755 contype = rvalue(r->expr_node.lhs, p1, RREQ);
756 codeon();
757 if (contype == NLNIL) {
758 return NLNIL;
759 }
760 }
761 /*
762 * Now we generate code for
763 * the operands of the relational
764 * operation.
765 */
766 p = rvalue(r->expr_node.lhs, contype , RREQ );
767 if (p == NLNIL)
768 return (NLNIL);
769 p1 = rvalue(r->expr_node.rhs, p , RREQ );
770 if (p1 == NLNIL)
771 return (NLNIL);
772 # endif OBJ
773 # ifdef PC
774 c1 = classify( p1 );
775 if ( c1 == TSET || c1 == TSTR || c1 == TREC ) {
776 putleaf( PCC_ICON , 0 , 0
777 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
778 , c1 == TSET ? relts[ r->tag - T_EQ ]
779 : relss[ r->tag - T_EQ ] );
780 /*
781 * for [] and strings, comparisons are done on
782 * the maximum width of the two sides.
783 * for other sets, we have to ask the left side
784 * what type it is based on the type of the right.
785 * (this matters for intsets).
786 */
787 if ( c1 == TSTR ) {
788 codeoff();
789 p = rvalue( r->expr_node.lhs , NLNIL , LREQ );
790 codeon();
791 if ( p == NLNIL ) {
792 return NLNIL;
793 }
794 if ( lwidth( p ) > lwidth( p1 ) ) {
795 contype = p;
796 }
797 } else if ( c1 == TSET ) {
798 codeoff();
799 contype = rvalue(r->expr_node.lhs, p1, LREQ);
800 codeon();
801 if (contype == NLNIL) {
802 return NLNIL;
803 }
804 }
805 /*
806 * put out the width of the comparison.
807 */
808 putleaf(PCC_ICON, (int) lwidth(contype), 0, PCCT_INT, (char *) 0);
809 /*
810 * and the left hand side,
811 * for sets, strings, records
812 */
813 p = rvalue( r->expr_node.lhs , contype , LREQ );
814 if ( p == NLNIL ) {
815 return NLNIL;
816 }
817 putop( PCC_CM , PCCT_INT );
818 p1 = rvalue( r->expr_node.rhs , p , LREQ );
819 if ( p1 == NLNIL ) {
820 return NLNIL;
821 }
822 putop( PCC_CM , PCCT_INT );
823 putop( PCC_CALL , PCCT_INT );
824 } else {
825 /*
826 * the easy (scalar or error) case
827 */
828 p = rvalue( r->expr_node.lhs , contype , RREQ );
829 if ( p == NLNIL ) {
830 return NLNIL;
831 }
832 /*
833 * since the second pass can't do
834 * long op double or double op long
835 * we may have to do some coercing.
836 */
837 tuac(p, p1, &rettype, (int *) (&ctype));
838 p1 = rvalue( r->expr_node.rhs , p , RREQ );
839 if ( p1 == NLNIL ) {
840 return NLNIL;
841 }
842 tuac(p1, p, &rettype, (int *) (&ctype));
843 putop((int) relops[ r->tag - T_EQ ] , PCCT_INT );
844 sconv(PCCT_INT, PCCT_CHAR);
845 }
846 # endif PC
847 c = classify(p);
848 c1 = classify(p1);
849 if (nocomp(c) || nocomp(c1))
850 return (NLNIL);
851 # ifdef OBJ
852 g = NIL;
853 # endif
854 switch (c) {
855 case TBOOL:
856 case TCHAR:
857 if (c != c1)
858 goto clash;
859 break;
860 case TINT:
861 case TDOUBLE:
862 if (c1 != TINT && c1 != TDOUBLE)
863 goto clash;
864 break;
865 case TSCAL:
866 if (c1 != TSCAL)
867 goto clash;
868 if (scalar(p) != scalar(p1))
869 goto nonident;
870 break;
871 case TSET:
872 if (c1 != TSET)
873 goto clash;
874 if ( opt( 's' ) &&
875 ( ( r->tag == T_LT) || (r->tag == T_GT) ) &&
876 ( line != nssetline ) ) {
877 nssetline = line;
878 standard();
879 error("%s comparison on sets is non-standard" , opname );
880 }
881 if (p != p1)
882 goto nonident;
883 # ifdef OBJ
884 g = TSET;
885 # endif
886 break;
887 case TREC:
888 if ( c1 != TREC ) {
889 goto clash;
890 }
891 if ( p != p1 ) {
892 goto nonident;
893 }
894 if (r->tag != T_EQ && r->tag != T_NE) {
895 error("%s not allowed on records - only allow = and <>" , opname );
896 return (NLNIL);
897 }
898 # ifdef OBJ
899 g = TREC;
900 # endif
901 break;
902 case TPTR:
903 case TNIL:
904 if (c1 != TPTR && c1 != TNIL)
905 goto clash;
906 if (r->tag != T_EQ && r->tag != T_NE) {
907 error("%s not allowed on pointers - only allow = and <>" , opname );
908 return (NLNIL);
909 }
910 if (p != nl+TNIL && p1 != nl+TNIL && p != p1)
911 goto nonident;
912 break;
913 case TSTR:
914 if (c1 != TSTR)
915 goto clash;
916 if (width(p) != width(p1)) {
917 error("Strings not same length in %s comparison", opname);
918 return (NLNIL);
919 }
920 # ifdef OBJ
921 g = TSTR;
922 # endif OBJ
923 break;
924 default:
925 panic("rval2");
926 }
927 # ifdef OBJ
928 return (gen(g, r->tag, width(p), width(p1)));
929 # endif OBJ
930 # ifdef PC
931 return nl + TBOOL;
932 # endif PC
933 clash:
934 error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname);
935 return (NLNIL);
936 nonident:
937 error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname);
938 return (NLNIL);
939
940 case T_IN:
941 rt = r->expr_node.rhs;
942 # ifdef OBJ
943 if (rt != TR_NIL && rt->tag == T_CSET) {
944 (void) precset( rt , NLNIL , &csetd );
945 p1 = csetd.csettype;
946 if (p1 == NLNIL)
947 return NLNIL;
948 postcset( rt, &csetd);
949 } else {
950 p1 = stkrval(r->expr_node.rhs, NLNIL , (long) RREQ );
951 rt = TR_NIL;
952 }
953 # endif OBJ
954 # ifdef PC
955 if (rt != TR_NIL && rt->tag == T_CSET) {
956 if ( precset( rt , NLNIL , &csetd ) ) {
957 putleaf( PCC_ICON , 0 , 0
958 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
959 , "_IN" );
960 } else {
961 putleaf( PCC_ICON , 0 , 0
962 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
963 , "_INCT" );
964 }
965 p1 = csetd.csettype;
966 if (p1 == NIL)
967 return NLNIL;
968 } else {
969 putleaf( PCC_ICON , 0 , 0
970 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
971 , "_IN" );
972 codeoff();
973 p1 = rvalue(r->expr_node.rhs, NLNIL , LREQ );
974 codeon();
975 }
976 # endif PC
977 p = stkrval(r->expr_node.lhs, NLNIL , (long) RREQ );
978 if (p == NIL || p1 == NIL)
979 return (NLNIL);
980 if (p1->class != (char) SET) {
981 error("Right operand of 'in' must be a set, not %s", nameof(p1));
982 return (NLNIL);
983 }
984 if (incompat(p, p1->type, r->expr_node.lhs)) {
985 cerror("Index type clashed with set component type for 'in'");
986 return (NLNIL);
987 }
988 setran(p1->type);
989 # ifdef OBJ
990 if (rt == TR_NIL || csetd.comptime)
991 (void) put(4, O_IN, width(p1), set.lwrb, set.uprbp);
992 else
993 (void) put(2, O_INCT,
994 (int)(3 + csetd.singcnt + 2*csetd.paircnt));
995 # endif OBJ
996 # ifdef PC
997 if ( rt == TR_NIL || rt->tag != T_CSET ) {
998 putleaf( PCC_ICON , set.lwrb , 0 , PCCT_INT , (char *) 0 );
999 putop( PCC_CM , PCCT_INT );
1000 putleaf( PCC_ICON , set.uprbp , 0 , PCCT_INT , (char *) 0 );
1001 putop( PCC_CM , PCCT_INT );
1002 p1 = rvalue( r->expr_node.rhs , NLNIL , LREQ );
1003 if ( p1 == NLNIL ) {
1004 return NLNIL;
1005 }
1006 putop( PCC_CM , PCCT_INT );
1007 } else if ( csetd.comptime ) {
1008 putleaf( PCC_ICON , set.lwrb , 0 , PCCT_INT , (char *) 0 );
1009 putop( PCC_CM , PCCT_INT );
1010 putleaf( PCC_ICON , set.uprbp , 0 , PCCT_INT , (char *) 0 );
1011 putop( PCC_CM , PCCT_INT );
1012 postcset( r->expr_node.rhs , &csetd );
1013 putop( PCC_CM , PCCT_INT );
1014 } else {
1015 postcset( r->expr_node.rhs , &csetd );
1016 }
1017 putop( PCC_CALL , PCCT_INT );
1018 sconv(PCCT_INT, PCCT_CHAR);
1019 # endif PC
1020 return (nl+T1BOOL);
1021 default:
1022 if (r->expr_node.lhs == TR_NIL)
1023 return (NLNIL);
1024 switch (r->tag) {
1025 default:
1026 panic("rval3");
1027
1028
1029 /*
1030 * An octal number
1031 */
1032 case T_BINT:
1033 f.pdouble = a8tol(r->const_node.cptr);
1034 goto conint;
1035
1036 /*
1037 * A decimal number
1038 */
1039 case T_INT:
1040 f.pdouble = atof(r->const_node.cptr);
1041 conint:
1042 if (f.pdouble > MAXINT || f.pdouble < MININT) {
1043 error("Constant too large for this implementation");
1044 return (NLNIL);
1045 }
1046 l = f.pdouble;
1047 # ifdef OBJ
1048 if (bytes(l, l) <= 2) {
1049 (void) put(2, O_CON2, ( short ) l);
1050 return (nl+T2INT);
1051 }
1052 (void) put(2, O_CON4, l);
1053 return (nl+T4INT);
1054 # endif OBJ
1055 # ifdef PC
1056 switch (bytes(l, l)) {
1057 case 1:
1058 putleaf(PCC_ICON, (int) l, 0, PCCT_CHAR,
1059 (char *) 0);
1060 return nl+T1INT;
1061 case 2:
1062 putleaf(PCC_ICON, (int) l, 0, PCCT_SHORT,
1063 (char *) 0);
1064 return nl+T2INT;
1065 case 4:
1066 putleaf(PCC_ICON, (int) l, 0, PCCT_INT,
1067 (char *) 0);
1068 return nl+T4INT;
1069 }
1070 # endif PC
1071
1072 /*
1073 * A floating point number
1074 */
1075 case T_FINT:
1076 # ifdef OBJ
1077 (void) put(2, O_CON8, atof(r->const_node.cptr));
1078 # endif OBJ
1079 # ifdef PC
1080 putCON8( atof( r->const_node.cptr ) );
1081 # endif PC
1082 return (nl+TDOUBLE);
1083
1084 /*
1085 * Constant strings. Note that constant characters
1086 * are constant strings of length one; there is
1087 * no constant string of length one.
1088 */
1089 case T_STRNG:
1090 cp = r->const_node.cptr;
1091 if (cp[1] == 0) {
1092 # ifdef OBJ
1093 (void) put(2, O_CONC, cp[0]);
1094 # endif OBJ
1095 # ifdef PC
1096 putleaf( PCC_ICON , cp[0] , 0 , PCCT_CHAR ,
1097 (char *) 0 );
1098 # endif PC
1099 return (nl+T1CHAR);
1100 }
1101 goto cstrng;
1102 }
1103
1104 }
1105 }
1106
1107 /*
1108 * Can a class appear
1109 * in a comparison ?
1110 */
nocomp(c)1111 nocomp(c)
1112 int c;
1113 {
1114
1115 switch (c) {
1116 case TREC:
1117 if ( line != reccompline ) {
1118 reccompline = line;
1119 warning();
1120 if ( opt( 's' ) ) {
1121 standard();
1122 }
1123 error("record comparison is non-standard");
1124 }
1125 break;
1126 case TFILE:
1127 case TARY:
1128 error("%ss may not participate in comparisons", clnames[c]);
1129 return (1);
1130 }
1131 return (NIL);
1132 }
1133
1134 /*
1135 * this is sort of like gconst, except it works on expression trees
1136 * rather than declaration trees, and doesn't give error messages for
1137 * non-constant things.
1138 * as a side effect this fills in the con structure that gconst uses.
1139 * this returns TRUE or FALSE.
1140 */
1141
1142 bool
constval(r)1143 constval(r)
1144 register struct tnode *r;
1145 {
1146 register struct nl *np;
1147 register struct tnode *cn;
1148 char *cp;
1149 int negd, sgnd;
1150 long ci;
1151
1152 con.ctype = NIL;
1153 cn = r;
1154 negd = sgnd = 0;
1155 loop:
1156 /*
1157 * cn[2] is nil if error recovery generated a T_STRNG
1158 */
1159 if (cn == TR_NIL || cn->expr_node.lhs == TR_NIL)
1160 return FALSE;
1161 switch (cn->tag) {
1162 default:
1163 return FALSE;
1164 case T_MINUS:
1165 negd = 1 - negd;
1166 /* and fall through */
1167 case T_PLUS:
1168 sgnd++;
1169 cn = cn->un_expr.expr;
1170 goto loop;
1171 case T_NIL:
1172 con.cpval = NIL;
1173 con.cival = 0;
1174 con.crval = con.cival;
1175 con.ctype = nl + TNIL;
1176 break;
1177 case T_VAR:
1178 np = lookup(cn->var_node.cptr);
1179 if (np == NLNIL || np->class != CONST) {
1180 return FALSE;
1181 }
1182 if ( cn->var_node.qual != TR_NIL ) {
1183 return FALSE;
1184 }
1185 con.ctype = np->type;
1186 switch (classify(np->type)) {
1187 case TINT:
1188 con.crval = np->range[0];
1189 break;
1190 case TDOUBLE:
1191 con.crval = np->real;
1192 break;
1193 case TBOOL:
1194 case TCHAR:
1195 case TSCAL:
1196 con.cival = np->value[0];
1197 con.crval = con.cival;
1198 break;
1199 case TSTR:
1200 con.cpval = (char *) np->ptr[0];
1201 break;
1202 default:
1203 con.ctype = NIL;
1204 return FALSE;
1205 }
1206 break;
1207 case T_BINT:
1208 con.crval = a8tol(cn->const_node.cptr);
1209 goto restcon;
1210 case T_INT:
1211 con.crval = atof(cn->const_node.cptr);
1212 if (con.crval > MAXINT || con.crval < MININT) {
1213 derror("Constant too large for this implementation");
1214 con.crval = 0;
1215 }
1216 restcon:
1217 ci = con.crval;
1218 #ifndef PI0
1219 if (bytes(ci, ci) <= 2)
1220 con.ctype = nl+T2INT;
1221 else
1222 #endif
1223 con.ctype = nl+T4INT;
1224 break;
1225 case T_FINT:
1226 con.ctype = nl+TDOUBLE;
1227 con.crval = atof(cn->const_node.cptr);
1228 break;
1229 case T_STRNG:
1230 cp = cn->const_node.cptr;
1231 if (cp[1] == 0) {
1232 con.ctype = nl+T1CHAR;
1233 con.cival = cp[0];
1234 con.crval = con.cival;
1235 break;
1236 }
1237 con.ctype = nl+TSTR;
1238 con.cpval = cp;
1239 break;
1240 }
1241 if (sgnd) {
1242 if (isnta(con.ctype, "id")) {
1243 derror("%s constants cannot be signed", nameof(con.ctype));
1244 return FALSE;
1245 } else if (negd)
1246 con.crval = -con.crval;
1247 }
1248 return TRUE;
1249 }
1250