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