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