xref: /original-bsd/usr.bin/pascal/src/rval.c (revision d25e1985) 
1 /* Copyright (c) 1979 Regents of the University of California */
2 
3 static	char sccsid[] = "@(#)rval.c 1.1 08/27/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 			    /*
308 			     * Function call with no arguments.
309 			     */
310 			    if (r[3]) {
311 				    error("Can't qualify a function result value");
312 				    return (NIL);
313 			    }
314 #			    ifdef OBJ
315 				return (funccod((int *) r));
316 #			    endif OBJ
317 #			    ifdef PC
318 				return (pcfunccod( r ));
319 #			    endif PC
320 
321 		    case TYPE:
322 			    error("Type names (e.g. %s) allowed only in declarations", p->symbol);
323 			    return (NIL);
324 
325 		    case PROC:
326 			    error("Procedure %s found where expression required", p->symbol);
327 			    return (NIL);
328 		    default:
329 			    panic("rvid");
330 		}
331 	/*
332 	 * Constant sets
333 	 */
334 	case T_CSET:
335 #		ifdef OBJ
336 		    if ( precset( r , contype , &csetd ) ) {
337 			if ( csetd.csettype == NIL ) {
338 			    return NIL;
339 			}
340 			postcset( r , &csetd );
341 		    } else {
342 			put( 2, O_PUSH, -width(csetd.csettype));
343 			postcset( r , &csetd );
344 			setran( ( csetd.csettype ) -> type );
345 			put( 2, O_CON24, set.uprbp);
346 			put( 2, O_CON24, set.lwrb);
347 			put( 2, O_CTTOT, 5 + csetd.singcnt + 2 * csetd.paircnt);
348 		    }
349 		    return csetd.csettype;
350 #		endif OBJ
351 #		ifdef PC
352 		    if ( precset( r , contype , &csetd ) ) {
353 			if ( csetd.csettype == NIL ) {
354 			    return NIL;
355 			}
356 			postcset( r , &csetd );
357 		    } else {
358 			putleaf( P2ICON , 0 , 0
359 				, ADDTYPE( P2FTN | P2INT , P2PTR )
360 				, "_CTTOT" );
361 			/*
362 			 *	allocate a temporary and use it
363 			 */
364 			sizes[ cbn ].om_off -= lwidth( csetd.csettype );
365 			tempoff = sizes[ cbn ].om_off;
366 			putlbracket( ftnno , -tempoff );
367 			if ( tempoff < sizes[ cbn ].om_max ) {
368 			    sizes[ cbn ].om_max = tempoff;
369 			}
370 			putLV( 0 , cbn , tempoff , P2PTR|P2STRTY );
371 			setran( ( csetd.csettype ) -> type );
372 			putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 );
373 			putop( P2LISTOP , P2INT );
374 			putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 );
375 			putop( P2LISTOP , P2INT );
376 			postcset( r , &csetd );
377 			putop( P2CALL , P2INT );
378 		    }
379 		    return csetd.csettype;
380 #		endif PC
381 
382 	/*
383 	 * Unary plus and minus
384 	 */
385 	case T_PLUS:
386 	case T_MINUS:
387 		q = rvalue(r[2], NIL , RREQ );
388 		if (q == NIL)
389 			return (NIL);
390 		if (isnta(q, "id")) {
391 			error("Operand of %s must be integer or real, not %s", opname, nameof(q));
392 			return (NIL);
393 		}
394 		if (r[0] == T_MINUS) {
395 #		    ifdef OBJ
396 			put(1, O_NEG2 + (width(q) >> 2));
397 #		    endif OBJ
398 #		    ifdef PC
399 			putop( P2UNARY P2MINUS , p2type( q ) );
400 #		    endif PC
401 		    return (isa(q, "d") ? q : nl+T4INT);
402 		}
403 		return (q);
404 
405 	case T_NOT:
406 		q = rvalue(r[2], NIL , RREQ );
407 		if (q == NIL)
408 			return (NIL);
409 		if (isnta(q, "b")) {
410 			error("not must operate on a Boolean, not %s", nameof(q));
411 			return (NIL);
412 		}
413 #		ifdef OBJ
414 		    put(1, O_NOT);
415 #		endif OBJ
416 #		ifdef PC
417 		    putop( P2NOT , P2INT );
418 #		endif PC
419 		return (nl+T1BOOL);
420 
421 	case T_AND:
422 	case T_OR:
423 		p = rvalue(r[2], NIL , RREQ );
424 		p1 = rvalue(r[3], NIL , RREQ );
425 		if (p == NIL || p1 == NIL)
426 			return (NIL);
427 		if (isnta(p, "b")) {
428 			error("Left operand of %s must be Boolean, not %s", opname, nameof(p));
429 			return (NIL);
430 		}
431 		if (isnta(p1, "b")) {
432 			error("Right operand of %s must be Boolean, not %s", opname, nameof(p1));
433 			return (NIL);
434 		}
435 #		ifdef OBJ
436 		    put(1, r[0] == T_AND ? O_AND : O_OR);
437 #		endif OBJ
438 #		ifdef PC
439 			/*
440 			 * note the use of & and | rather than && and ||
441 			 * to force evaluation of all the expressions.
442 			 */
443 		    putop( r[ 0 ] == T_AND ? P2AND : P2OR , P2INT );
444 #		endif PC
445 		return (nl+T1BOOL);
446 
447 	case T_DIVD:
448 #		ifdef OBJ
449 		    p = rvalue(r[2], NIL , RREQ );
450 		    p1 = rvalue(r[3], NIL , RREQ );
451 #		endif OBJ
452 #		ifdef PC
453 			/*
454 			 *	force these to be doubles for the divide
455 			 */
456 		    p = rvalue( r[ 2 ] , NIL , RREQ );
457 		    if ( isnta( p , "d" ) ) {
458 			putop( P2SCONV , P2DOUBLE );
459 		    }
460 		    p1 = rvalue( r[ 3 ] , NIL , RREQ );
461 		    if ( isnta( p1 , "d" ) ) {
462 			putop( P2SCONV , P2DOUBLE );
463 		    }
464 #		endif PC
465 		if (p == NIL || p1 == NIL)
466 			return (NIL);
467 		if (isnta(p, "id")) {
468 			error("Left operand of / must be integer or real, not %s", nameof(p));
469 			return (NIL);
470 		}
471 		if (isnta(p1, "id")) {
472 			error("Right operand of / must be integer or real, not %s", nameof(p1));
473 			return (NIL);
474 		}
475 #		ifdef OBJ
476 		    return gen(NIL, r[0], width(p), width(p1));
477 #		endif OBJ
478 #		ifdef PC
479 		    putop( P2DIV , P2DOUBLE );
480 		    return nl + TDOUBLE;
481 #		endif PC
482 
483 	case T_MULT:
484 	case T_ADD:
485 	case T_SUB:
486 #		ifdef OBJ
487 		    /*
488 		     * If the context hasn't told us
489 		     * the type and a constant set is
490 		     * present on the left we need to infer
491 		     * the type from the right if possible
492 		     * before generating left side code.
493 		     */
494 		    if (contype == NIL && (rt = r[2]) != NIL && rt[1] == SAWCON) {
495 			    codeoff();
496 			    contype = rvalue(r[3], NIL , RREQ );
497 			    codeon();
498 			    if (contype == NIL)
499 				    return (NIL);
500 		    }
501 		    p = rvalue(r[2], contype , RREQ );
502 		    p1 = rvalue(r[3], p , RREQ );
503 		    if (p == NIL || p1 == NIL)
504 			    return (NIL);
505 		    if (isa(p, "id") && isa(p1, "id"))
506 			return (gen(NIL, r[0], width(p), width(p1)));
507 		    if (isa(p, "t") && isa(p1, "t")) {
508 			    if (p != p1) {
509 				    error("Set types of operands of %s must be identical", opname);
510 				    return (NIL);
511 			    }
512 			    gen(TSET, r[0], width(p), 0);
513 			    return (p);
514 		    }
515 #		endif OBJ
516 #		ifdef PC
517 			/*
518 			 * the second pass can't do
519 			 *	long op double  or  double op long
520 			 * so we have to know the type of both operands
521 			 * also, it gets tricky for sets, which are done
522 			 * by function calls.
523 			 */
524 		    codeoff();
525 		    p1 = rvalue( r[ 3 ] , contype , RREQ );
526 		    codeon();
527 		    if ( isa( p1 , "id" ) ) {
528 			p = rvalue( r[ 2 ] , contype , RREQ );
529 			if ( ( p == NIL ) || ( p1 == NIL ) ) {
530 			    return NIL;
531 			}
532 			if ( isa( p , "i" ) && isa( p1 , "d" ) ) {
533 			    putop( P2SCONV , P2DOUBLE );
534 			}
535 			p1 = rvalue( r[ 3 ] , contype , RREQ );
536 			if ( isa( p , "d" ) && isa( p1 , "i" ) ) {
537 			    putop( P2SCONV , P2DOUBLE );
538 			}
539 			if ( isa( p , "id" ) ) {
540 			    if ( isa( p , "d" ) || isa( p1 , "d" ) ) {
541 				ctype = P2DOUBLE;
542 				rettype = nl + TDOUBLE;
543 			    } else {
544 				ctype = P2INT;
545 				rettype = nl + T4INT;
546 			    }
547 			    putop( mathop[ r[0] - T_MULT ] , ctype );
548 			    return rettype;
549 			}
550 		    }
551 		    if ( isa( p1 , "t" ) ) {
552 			putleaf( P2ICON , 0 , 0
553 			    , ADDTYPE( ADDTYPE( P2PTR | P2STRTY , P2FTN )
554 					, P2PTR )
555 			    , setop[ r[0] - T_MULT ] );
556 			/*
557 			 *	allocate a temporary and use it
558 			 */
559 			sizes[ cbn ].om_off -= lwidth( p1 );
560 			tempoff = sizes[ cbn ].om_off;
561 			putlbracket( ftnno , -tempoff );
562 			if ( tempoff < sizes[ cbn ].om_max ) {
563 			    sizes[ cbn ].om_max = tempoff;
564 			}
565 			putLV( 0 , cbn , tempoff , P2PTR|P2STRTY );
566 			p = rvalue( r[2] , p1 , LREQ );
567 			if ( isa( p , "t" ) ) {
568 			    putop( P2LISTOP , P2INT );
569 			    if ( p == NIL || p1 == NIL ) {
570 				return NIL;
571 			    }
572 			    p1 = rvalue( r[3] , p , LREQ );
573 			    if ( p != p1 ) {
574 				error("Set types of operands of %s must be identical", opname);
575 				return NIL;
576 			    }
577 			    putop( P2LISTOP , P2INT );
578 			    putleaf( P2ICON , lwidth( p1 ) / sizeof( long ) , 0
579 				    , P2INT , 0 );
580 			    putop( P2LISTOP , P2INT );
581 			    putop( P2CALL , P2PTR | P2STRTY );
582 			    return p;
583 			}
584 		    }
585 		    if ( isnta( p1 , "idt" ) ) {
586 			    /*
587 			     *	find type of left operand for error message.
588 			     */
589 			p = rvalue( r[2] , contype , RREQ );
590 		    }
591 			/*
592 			 *	don't give spurious error messages.
593 			 */
594 		    if ( p == NIL || p1 == NIL ) {
595 			return NIL;
596 		    }
597 #		endif PC
598 		if (isnta(p, "idt")) {
599 			error("Left operand of %s must be integer, real or set, not %s", opname, nameof(p));
600 			return (NIL);
601 		}
602 		if (isnta(p1, "idt")) {
603 			error("Right operand of %s must be integer, real or set, not %s", opname, nameof(p1));
604 			return (NIL);
605 		}
606 		error("Cannot mix sets with integers and reals as operands of %s", opname);
607 		return (NIL);
608 
609 	case T_MOD:
610 	case T_DIV:
611 		p = rvalue(r[2], NIL , RREQ );
612 		p1 = rvalue(r[3], NIL , RREQ );
613 		if (p == NIL || p1 == NIL)
614 			return (NIL);
615 		if (isnta(p, "i")) {
616 			error("Left operand of %s must be integer, not %s", opname, nameof(p));
617 			return (NIL);
618 		}
619 		if (isnta(p1, "i")) {
620 			error("Right operand of %s must be integer, not %s", opname, nameof(p1));
621 			return (NIL);
622 		}
623 #		ifdef OBJ
624 		    return (gen(NIL, r[0], width(p), width(p1)));
625 #		endif OBJ
626 #		ifdef PC
627 		    putop( r[ 0 ] == T_DIV ? P2DIV : P2MOD , P2INT );
628 		    return ( nl + T4INT );
629 #		endif PC
630 
631 	case T_EQ:
632 	case T_NE:
633 	case T_LT:
634 	case T_GT:
635 	case T_LE:
636 	case T_GE:
637 		/*
638 		 * Since there can be no, a priori, knowledge
639 		 * of the context type should a constant string
640 		 * or set arise, we must poke around to find such
641 		 * a type if possible.  Since constant strings can
642 		 * always masquerade as identifiers, this is always
643 		 * necessary.
644 		 */
645 		codeoff();
646 		p1 = rvalue(r[3], NIL , RREQ );
647 		codeon();
648 		if (p1 == NIL)
649 			return (NIL);
650 		contype = p1;
651 #		ifdef OBJ
652 		    if (p1 == nl+TSET || p1->class == STR) {
653 			    /*
654 			     * For constant strings we want
655 			     * the longest type so as to be
656 			     * able to do padding (more importantly
657 			     * avoiding truncation). For clarity,
658 			     * we get this length here.
659 			     */
660 			    codeoff();
661 			    p = rvalue(r[2], NIL , RREQ );
662 			    codeon();
663 			    if (p == NIL)
664 				    return (NIL);
665 			    if (p1 == nl+TSET || width(p) > width(p1))
666 				    contype = p;
667 		    }
668 		    /*
669 		     * Now we generate code for
670 		     * the operands of the relational
671 		     * operation.
672 		     */
673 		    p = rvalue(r[2], contype , RREQ );
674 		    if (p == NIL)
675 			    return (NIL);
676 		    p1 = rvalue(r[3], p , RREQ );
677 		    if (p1 == NIL)
678 			    return (NIL);
679 #		endif OBJ
680 #		ifdef PC
681 		    c1 = classify( p1 );
682 		    if ( c1 == TSET || c1 == TSTR || c1 == TREC ) {
683 			putleaf( P2ICON , 0 , 0
684 				, ADDTYPE( P2FTN | P2INT , P2PTR )
685 				, c1 == TSET  ? relts[ r[0] - T_EQ ]
686 					      : relss[ r[0] - T_EQ ] );
687 			    /*
688 			     *	for [] and strings, comparisons are done on
689 			     *	the maximum width of the two sides.
690 			     *	for other sets, we have to ask the left side
691 			     *	what type it is based on the type of the right.
692 			     *	(this matters for intsets).
693 			     */
694 			if ( p1 == nl + TSET || c1 == TSTR ) {
695 			    codeoff();
696 			    p = rvalue( r[ 2 ] , NIL , LREQ );
697 			    codeon();
698 			    if (   p1 == nl + TSET
699 				|| lwidth( p ) > lwidth( p1 ) ) {
700 				contype = p;
701 			    }
702 			} else {
703 			    codeoff();
704 			    p = rvalue( r[ 2 ] , contype , LREQ );
705 			    codeon();
706 			    contype = p;
707 			}
708 			if ( p == NIL ) {
709 			    return NIL;
710 			}
711 			    /*
712 			     *	put out the width of the comparison.
713 			     */
714 			putleaf( P2ICON , lwidth( contype ) , 0 , P2INT , 0 );
715 			    /*
716 			     *	and the left hand side,
717 			     *	for sets, strings, records
718 			     */
719 			p = rvalue( r[ 2 ] , contype , LREQ );
720 			putop( P2LISTOP , P2INT );
721 			p1 = rvalue( r[ 3 ] , p , LREQ );
722 			putop( P2LISTOP , P2INT );
723 			putop( P2CALL , P2INT );
724 		    } else {
725 			    /*
726 			     *	the easy (scalar or error) case
727 			     */
728 			p = rvalue( r[ 2 ] , contype , RREQ );
729 			if ( p == NIL ) {
730 			    return NIL;
731 			    /*
732 			     * since the second pass can't do
733 			     *	long op double  or  double op long
734 			     * we may have to do some coercing.
735 			     */
736 			if ( isa( p , "i" ) && isa( p1 , "d" ) )
737 			    putop( P2SCONV , P2DOUBLE );
738 			}
739 			p1 = rvalue( r[ 3 ] , p , RREQ );
740 			if ( isa( p , "d" ) && isa( p1 , "i" ) )
741 			    putop( P2SCONV , P2DOUBLE );
742 			putop( relops[ r[0] - T_EQ ] , P2INT );
743 		    }
744 #		endif PC
745 		c = classify(p);
746 		c1 = classify(p1);
747 		if (nocomp(c) || nocomp(c1))
748 			return (NIL);
749 		g = NIL;
750 		switch (c) {
751 			case TBOOL:
752 			case TCHAR:
753 				if (c != c1)
754 					goto clash;
755 				break;
756 			case TINT:
757 			case TDOUBLE:
758 				if (c1 != TINT && c1 != TDOUBLE)
759 					goto clash;
760 				break;
761 			case TSCAL:
762 				if (c1 != TSCAL)
763 					goto clash;
764 				if (scalar(p) != scalar(p1))
765 					goto nonident;
766 				break;
767 			case TSET:
768 				if (c1 != TSET)
769 					goto clash;
770 				if (p != p1)
771 					goto nonident;
772 				g = TSET;
773 				break;
774 			case TREC:
775 				if ( c1 != TREC ) {
776 				    goto clash;
777 				}
778 				if ( p != p1 ) {
779 				    goto nonident;
780 				}
781 				if (r[0] != T_EQ && r[0] != T_NE) {
782 					error("%s not allowed on records - only allow = and <>" , opname );
783 					return (NIL);
784 				}
785 				g = TREC;
786 				break;
787 			case TPTR:
788 			case TNIL:
789 				if (c1 != TPTR && c1 != TNIL)
790 					goto clash;
791 				if (r[0] != T_EQ && r[0] != T_NE) {
792 					error("%s not allowed on pointers - only allow = and <>" , opname );
793 					return (NIL);
794 				}
795 				break;
796 			case TSTR:
797 				if (c1 != TSTR)
798 					goto clash;
799 				if (width(p) != width(p1)) {
800 					error("Strings not same length in %s comparison", opname);
801 					return (NIL);
802 				}
803 				g = TSTR;
804 				break;
805 			default:
806 				panic("rval2");
807 		}
808 #		ifdef OBJ
809 		    return (gen(g, r[0], width(p), width(p1)));
810 #		endif OBJ
811 #		ifdef PC
812 		    return nl + TBOOL;
813 #		endif PC
814 clash:
815 		error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname);
816 		return (NIL);
817 nonident:
818 		error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname);
819 		return (NIL);
820 
821 	case T_IN:
822 	    rt = r[3];
823 #	    ifdef OBJ
824 		if (rt != NIL && rt[0] == T_CSET) {
825 			precset( rt , NIL , &csetd );
826 			p1 = csetd.csettype;
827 			if (p1 == NIL)
828 			    return NIL;
829 			if (p1 == nl+TSET) {
830 			    if ( !inempty ) {
831 				warning();
832 				error("... in [] makes little sense, since it is always false!");
833 				inempty = TRUE;
834 			    }
835 			    put(1, O_CON1, 0);
836 			    return (nl+T1BOOL);
837 			}
838 			postcset( rt, &csetd);
839 		    } else {
840 			p1 = stkrval(r[3], NIL , RREQ );
841 			rt = NIL;
842 		    }
843 #		endif OBJ
844 #		ifdef PC
845 		    if (rt != NIL && rt[0] == T_CSET) {
846 			if ( precset( rt , NIL , &csetd ) ) {
847 			    if ( csetd.csettype != nl + TSET ) {
848 				putleaf( P2ICON , 0 , 0
849 					, ADDTYPE( P2FTN | P2INT , P2PTR )
850 					, "_IN" );
851 			    }
852 			} else {
853 			    putleaf( P2ICON , 0 , 0
854 				    , ADDTYPE( P2FTN | P2INT , P2PTR )
855 				    , "_INCT" );
856 			}
857 			p1 = csetd.csettype;
858 			if (p1 == NIL)
859 			    return NIL;
860 			if ( p1 == nl + TSET ) {
861 			    if ( !inempty ) {
862 				warning();
863 				error("... in [] makes little sense, since it is always false!");
864 				inempty = TRUE;
865 			    }
866 			    putleaf( P2ICON , 0 , 0 , P2INT , 0 );
867 			    return (nl+T1BOOL);
868 			}
869 		    } else {
870 			putleaf( P2ICON , 0 , 0
871 				, ADDTYPE( P2FTN | P2INT , P2PTR )
872 				, "_IN" );
873 			codeoff();
874 			p1 = rvalue(r[3], NIL , LREQ );
875 			codeon();
876 		    }
877 #		endif PC
878 		p = stkrval(r[2], NIL , RREQ );
879 		if (p == NIL || p1 == NIL)
880 			return (NIL);
881 		if (p1->class != SET) {
882 			error("Right operand of 'in' must be a set, not %s", nameof(p1));
883 			return (NIL);
884 		}
885 		if (incompat(p, p1->type, r[2])) {
886 			cerror("Index type clashed with set component type for 'in'");
887 			return (NIL);
888 		}
889 		setran(p1->type);
890 #		ifdef OBJ
891 		    if (rt == NIL || csetd.comptime)
892 			    put(4, O_IN, width(p1), set.lwrb, set.uprbp);
893 		    else
894 			    put(2, O_INCT, 3 + csetd.singcnt + 2*csetd.paircnt);
895 #		endif OBJ
896 #		ifdef PC
897 		    if ( rt == NIL || rt[0] != T_CSET ) {
898 			putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 );
899 			putop( P2LISTOP , P2INT );
900 			putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 );
901 			putop( P2LISTOP , P2INT );
902 			p1 = rvalue( r[3] , NIL , LREQ );
903 			putop( P2LISTOP , P2INT );
904 		    } else if ( csetd.comptime ) {
905 			putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 );
906 			putop( P2LISTOP , P2INT );
907 			putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 );
908 			putop( P2LISTOP , P2INT );
909 			postcset( r[3] , &csetd );
910 			putop( P2LISTOP , P2INT );
911 		    } else {
912 			postcset( r[3] , &csetd );
913 		    }
914 		    putop( P2CALL , P2INT );
915 #		endif PC
916 		return (nl+T1BOOL);
917 	default:
918 		if (r[2] == NIL)
919 			return (NIL);
920 		switch (r[0]) {
921 		default:
922 			panic("rval3");
923 
924 
925 		/*
926 		 * An octal number
927 		 */
928 		case T_BINT:
929 			f = a8tol(r[2]);
930 			goto conint;
931 
932 		/*
933 		 * A decimal number
934 		 */
935 		case T_INT:
936 			f = atof(r[2]);
937 conint:
938 			if (f > MAXINT || f < MININT) {
939 				error("Constant too large for this implementation");
940 				return (NIL);
941 			}
942 			l = f;
943 			if (bytes(l, l) <= 2) {
944 #				ifdef OBJ
945 				    put(2, O_CON2, ( short ) l);
946 #				endif OBJ
947 #				ifdef PC
948 				        /*
949 					 * short constants are ints
950 					 */
951 				    putleaf( P2ICON , l , 0 , P2INT , 0 );
952 #				endif PC
953 				return (nl+T2INT);
954 			}
955 #			ifdef OBJ
956 			    put(2, O_CON4, l);
957 #			endif OBJ
958 #			ifdef PC
959 			    putleaf( P2ICON , l , 0 , P2INT , 0 );
960 #			endif PC
961 			return (nl+T4INT);
962 
963 		/*
964 		 * A floating point number
965 		 */
966 		case T_FINT:
967 #			ifdef OBJ
968 			    put(2, O_CON8, atof(r[2]));
969 #			endif OBJ
970 #			ifdef PC
971 			    putCON8( atof( r[2] ) );
972 #			endif PC
973 			return (nl+TDOUBLE);
974 
975 		/*
976 		 * Constant strings.  Note that constant characters
977 		 * are constant strings of length one; there is
978 		 * no constant string of length one.
979 		 */
980 		case T_STRNG:
981 			cp = r[2];
982 			if (cp[1] == 0) {
983 #				ifdef OBJ
984 				    put(2, O_CONC, cp[0]);
985 #				endif OBJ
986 #				ifdef PC
987 				    putleaf( P2ICON , cp[0] , 0 , P2CHAR , 0 );
988 #				endif PC
989 				return (nl+T1CHAR);
990 			}
991 			goto cstrng;
992 		}
993 
994 	}
995 }
996 
997 /*
998  * Can a class appear
999  * in a comparison ?
1000  */
1001 nocomp(c)
1002 	int c;
1003 {
1004 
1005 	switch (c) {
1006 		case TREC:
1007 			if ( opt( 's' ) ) {
1008 			    standard();
1009 			    error("record comparison is non-standard");
1010 			}
1011 			break;
1012 		case TFILE:
1013 		case TARY:
1014 			error("%ss may not participate in comparisons", clnames[c]);
1015 			return (1);
1016 	}
1017 	return (NIL);
1018 }
1019 
1020     /*
1021      *	this is sort of like gconst, except it works on expression trees
1022      *	rather than declaration trees, and doesn't give error messages for
1023      *	non-constant things.
1024      *	as a side effect this fills in the con structure that gconst uses.
1025      *	this returns TRUE or FALSE.
1026      */
1027 constval(r)
1028 	register int *r;
1029 {
1030 	register struct nl *np;
1031 	register *cn;
1032 	char *cp;
1033 	int negd, sgnd;
1034 	long ci;
1035 
1036 	con.ctype = NIL;
1037 	cn = r;
1038 	negd = sgnd = 0;
1039 loop:
1040 	    /*
1041 	     *	cn[2] is nil if error recovery generated a T_STRNG
1042 	     */
1043 	if (cn == NIL || cn[2] == NIL)
1044 		return FALSE;
1045 	switch (cn[0]) {
1046 		default:
1047 			return FALSE;
1048 		case T_MINUS:
1049 			negd = 1 - negd;
1050 			/* and fall through */
1051 		case T_PLUS:
1052 			sgnd++;
1053 			cn = cn[2];
1054 			goto loop;
1055 		case T_NIL:
1056 			con.cpval = NIL;
1057 			con.cival = 0;
1058 			con.crval = con.cival;
1059 			con.ctype = nl + TNIL;
1060 			break;
1061 		case T_VAR:
1062 			np = lookup(cn[2]);
1063 			if (np == NIL || np->class != CONST) {
1064 				return FALSE;
1065 			}
1066 			if ( cn[3] != NIL ) {
1067 				return FALSE;
1068 			}
1069 			con.ctype = np->type;
1070 			switch (classify(np->type)) {
1071 				case TINT:
1072 					con.crval = np->range[0];
1073 					break;
1074 				case TDOUBLE:
1075 					con.crval = np->real;
1076 					break;
1077 				case TBOOL:
1078 				case TCHAR:
1079 				case TSCAL:
1080 					con.cival = np->value[0];
1081 					con.crval = con.cival;
1082 					break;
1083 				case TSTR:
1084 					con.cpval = np->ptr[0];
1085 					break;
1086 				default:
1087 					con.ctype = NIL;
1088 					return FALSE;
1089 			}
1090 			break;
1091 		case T_BINT:
1092 			con.crval = a8tol(cn[2]);
1093 			goto restcon;
1094 		case T_INT:
1095 			con.crval = atof(cn[2]);
1096 			if (con.crval > MAXINT || con.crval < MININT) {
1097 				derror("Constant too large for this implementation");
1098 				con.crval = 0;
1099 			}
1100 restcon:
1101 			ci = con.crval;
1102 #ifndef PI0
1103 			if (bytes(ci, ci) <= 2)
1104 				con.ctype = nl+T2INT;
1105 			else
1106 #endif
1107 				con.ctype = nl+T4INT;
1108 			break;
1109 		case T_FINT:
1110 			con.ctype = nl+TDOUBLE;
1111 			con.crval = atof(cn[2]);
1112 			break;
1113 		case T_STRNG:
1114 			cp = cn[2];
1115 			if (cp[1] == 0) {
1116 				con.ctype = nl+T1CHAR;
1117 				con.cival = cp[0];
1118 				con.crval = con.cival;
1119 				break;
1120 			}
1121 			con.ctype = nl+TSTR;
1122 			con.cpval = cp;
1123 			break;
1124 	}
1125 	if (sgnd) {
1126 		if (isnta(con.ctype, "id")) {
1127 			derror("%s constants cannot be signed", nameof(con.ctype));
1128 			return FALSE;
1129 		} else if (negd)
1130 			con.crval = -con.crval;
1131 	}
1132 	return TRUE;
1133 }
1134