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