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