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