xref: /csrg-svn/usr.bin/pascal/src/rval.c (revision 1627) 
1 /* Copyright (c) 1979 Regents of the University of California */
2 
3 static	char sccsid[] = "@(#)rval.c 1.5 10/28/80";
4 
5 #include "whoami.h"
6 #include "0.h"
7 #include "tree.h"
8 #include "opcode.h"
9 #include "objfmt.h"
10 #ifdef PC
11 #   include	"pc.h"
12 #   include "pcops.h"
13 #endif PC
14 
15 extern	char *opnames[];
16 
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, 5 + 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 			     * since the second pass can't do
766 			     *	long op double  or  double op long
767 			     * we may have to do some coercing.
768 			     */
769 			if ( isa( p , "i" ) && isa( p1 , "d" ) )
770 			    putop( P2SCONV , P2DOUBLE );
771 			}
772 			p1 = rvalue( r[ 3 ] , p , RREQ );
773 			if ( isa( p , "d" ) && isa( p1 , "i" ) )
774 			    putop( P2SCONV , P2DOUBLE );
775 			putop( relops[ r[0] - T_EQ ] , P2INT );
776 		    }
777 #		endif PC
778 		c = classify(p);
779 		c1 = classify(p1);
780 		if (nocomp(c) || nocomp(c1))
781 			return (NIL);
782 		g = NIL;
783 		switch (c) {
784 			case TBOOL:
785 			case TCHAR:
786 				if (c != c1)
787 					goto clash;
788 				break;
789 			case TINT:
790 			case TDOUBLE:
791 				if (c1 != TINT && c1 != TDOUBLE)
792 					goto clash;
793 				break;
794 			case TSCAL:
795 				if (c1 != TSCAL)
796 					goto clash;
797 				if (scalar(p) != scalar(p1))
798 					goto nonident;
799 				break;
800 			case TSET:
801 				if (c1 != TSET)
802 					goto clash;
803 				if (p != p1)
804 					goto nonident;
805 				g = TSET;
806 				break;
807 			case TREC:
808 				if ( c1 != TREC ) {
809 				    goto clash;
810 				}
811 				if ( p != p1 ) {
812 				    goto nonident;
813 				}
814 				if (r[0] != T_EQ && r[0] != T_NE) {
815 					error("%s not allowed on records - only allow = and <>" , opname );
816 					return (NIL);
817 				}
818 				g = TREC;
819 				break;
820 			case TPTR:
821 			case TNIL:
822 				if (c1 != TPTR && c1 != TNIL)
823 					goto clash;
824 				if (r[0] != T_EQ && r[0] != T_NE) {
825 					error("%s not allowed on pointers - only allow = and <>" , opname );
826 					return (NIL);
827 				}
828 				break;
829 			case TSTR:
830 				if (c1 != TSTR)
831 					goto clash;
832 				if (width(p) != width(p1)) {
833 					error("Strings not same length in %s comparison", opname);
834 					return (NIL);
835 				}
836 				g = TSTR;
837 				break;
838 			default:
839 				panic("rval2");
840 		}
841 #		ifdef OBJ
842 		    return (gen(g, r[0], width(p), width(p1)));
843 #		endif OBJ
844 #		ifdef PC
845 		    return nl + TBOOL;
846 #		endif PC
847 clash:
848 		error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname);
849 		return (NIL);
850 nonident:
851 		error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname);
852 		return (NIL);
853 
854 	case T_IN:
855 	    rt = r[3];
856 #	    ifdef OBJ
857 		if (rt != NIL && rt[0] == T_CSET) {
858 			precset( rt , NIL , &csetd );
859 			p1 = csetd.csettype;
860 			if (p1 == NIL)
861 			    return NIL;
862 			postcset( rt, &csetd);
863 		    } else {
864 			p1 = stkrval(r[3], NIL , RREQ );
865 			rt = NIL;
866 		    }
867 #		endif OBJ
868 #		ifdef PC
869 		    if (rt != NIL && rt[0] == T_CSET) {
870 			if ( precset( rt , NIL , &csetd ) ) {
871 			    putleaf( P2ICON , 0 , 0
872 				    , ADDTYPE( P2FTN | P2INT , P2PTR )
873 				    , "_IN" );
874 			} else {
875 			    putleaf( P2ICON , 0 , 0
876 				    , ADDTYPE( P2FTN | P2INT , P2PTR )
877 				    , "_INCT" );
878 			}
879 			p1 = csetd.csettype;
880 			if (p1 == NIL)
881 			    return NIL;
882 		    } else {
883 			putleaf( P2ICON , 0 , 0
884 				, ADDTYPE( P2FTN | P2INT , P2PTR )
885 				, "_IN" );
886 			codeoff();
887 			p1 = rvalue(r[3], NIL , LREQ );
888 			codeon();
889 		    }
890 #		endif PC
891 		p = stkrval(r[2], NIL , RREQ );
892 		if (p == NIL || p1 == NIL)
893 			return (NIL);
894 		if (p1->class != SET) {
895 			error("Right operand of 'in' must be a set, not %s", nameof(p1));
896 			return (NIL);
897 		}
898 		if (incompat(p, p1->type, r[2])) {
899 			cerror("Index type clashed with set component type for 'in'");
900 			return (NIL);
901 		}
902 		setran(p1->type);
903 #		ifdef OBJ
904 		    if (rt == NIL || csetd.comptime)
905 			    put(4, O_IN, width(p1), set.lwrb, set.uprbp);
906 		    else
907 			    put(2, O_INCT, 3 + csetd.singcnt + 2*csetd.paircnt);
908 #		endif OBJ
909 #		ifdef PC
910 		    if ( rt == NIL || rt[0] != T_CSET ) {
911 			putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 );
912 			putop( P2LISTOP , P2INT );
913 			putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 );
914 			putop( P2LISTOP , P2INT );
915 			p1 = rvalue( r[3] , NIL , LREQ );
916 			putop( P2LISTOP , P2INT );
917 		    } else if ( csetd.comptime ) {
918 			putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 );
919 			putop( P2LISTOP , P2INT );
920 			putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 );
921 			putop( P2LISTOP , P2INT );
922 			postcset( r[3] , &csetd );
923 			putop( P2LISTOP , P2INT );
924 		    } else {
925 			postcset( r[3] , &csetd );
926 		    }
927 		    putop( P2CALL , P2INT );
928 #		endif PC
929 		return (nl+T1BOOL);
930 	default:
931 		if (r[2] == NIL)
932 			return (NIL);
933 		switch (r[0]) {
934 		default:
935 			panic("rval3");
936 
937 
938 		/*
939 		 * An octal number
940 		 */
941 		case T_BINT:
942 			f = a8tol(r[2]);
943 			goto conint;
944 
945 		/*
946 		 * A decimal number
947 		 */
948 		case T_INT:
949 			f = atof(r[2]);
950 conint:
951 			if (f > MAXINT || f < MININT) {
952 				error("Constant too large for this implementation");
953 				return (NIL);
954 			}
955 			l = f;
956 			if (bytes(l, l) <= 2) {
957 #				ifdef OBJ
958 				    put(2, O_CON2, ( short ) l);
959 #				endif OBJ
960 #				ifdef PC
961 				        /*
962 					 * short constants are ints
963 					 */
964 				    putleaf( P2ICON , l , 0 , P2INT , 0 );
965 #				endif PC
966 				return (nl+T2INT);
967 			}
968 #			ifdef OBJ
969 			    put(2, O_CON4, l);
970 #			endif OBJ
971 #			ifdef PC
972 			    putleaf( P2ICON , l , 0 , P2INT , 0 );
973 #			endif PC
974 			return (nl+T4INT);
975 
976 		/*
977 		 * A floating point number
978 		 */
979 		case T_FINT:
980 #			ifdef OBJ
981 			    put(2, O_CON8, atof(r[2]));
982 #			endif OBJ
983 #			ifdef PC
984 			    putCON8( atof( r[2] ) );
985 #			endif PC
986 			return (nl+TDOUBLE);
987 
988 		/*
989 		 * Constant strings.  Note that constant characters
990 		 * are constant strings of length one; there is
991 		 * no constant string of length one.
992 		 */
993 		case T_STRNG:
994 			cp = r[2];
995 			if (cp[1] == 0) {
996 #				ifdef OBJ
997 				    put(2, O_CONC, cp[0]);
998 #				endif OBJ
999 #				ifdef PC
1000 				    putleaf( P2ICON , cp[0] , 0 , P2CHAR , 0 );
1001 #				endif PC
1002 				return (nl+T1CHAR);
1003 			}
1004 			goto cstrng;
1005 		}
1006 
1007 	}
1008 }
1009 
1010 /*
1011  * Can a class appear
1012  * in a comparison ?
1013  */
1014 nocomp(c)
1015 	int c;
1016 {
1017 
1018 	switch (c) {
1019 		case TREC:
1020 			if ( line != reccompline ) {
1021 			    reccompline = line;
1022 			    warning();
1023 			    if ( opt( 's' ) ) {
1024 				standard();
1025 			    }
1026 			    error("record comparison is non-standard");
1027 			}
1028 			break;
1029 		case TFILE:
1030 		case TARY:
1031 			error("%ss may not participate in comparisons", clnames[c]);
1032 			return (1);
1033 	}
1034 	return (NIL);
1035 }
1036 
1037     /*
1038      *	this is sort of like gconst, except it works on expression trees
1039      *	rather than declaration trees, and doesn't give error messages for
1040      *	non-constant things.
1041      *	as a side effect this fills in the con structure that gconst uses.
1042      *	this returns TRUE or FALSE.
1043      */
1044 constval(r)
1045 	register int *r;
1046 {
1047 	register struct nl *np;
1048 	register *cn;
1049 	char *cp;
1050 	int negd, sgnd;
1051 	long ci;
1052 
1053 	con.ctype = NIL;
1054 	cn = r;
1055 	negd = sgnd = 0;
1056 loop:
1057 	    /*
1058 	     *	cn[2] is nil if error recovery generated a T_STRNG
1059 	     */
1060 	if (cn == NIL || cn[2] == NIL)
1061 		return FALSE;
1062 	switch (cn[0]) {
1063 		default:
1064 			return FALSE;
1065 		case T_MINUS:
1066 			negd = 1 - negd;
1067 			/* and fall through */
1068 		case T_PLUS:
1069 			sgnd++;
1070 			cn = cn[2];
1071 			goto loop;
1072 		case T_NIL:
1073 			con.cpval = NIL;
1074 			con.cival = 0;
1075 			con.crval = con.cival;
1076 			con.ctype = nl + TNIL;
1077 			break;
1078 		case T_VAR:
1079 			np = lookup(cn[2]);
1080 			if (np == NIL || np->class != CONST) {
1081 				return FALSE;
1082 			}
1083 			if ( cn[3] != NIL ) {
1084 				return FALSE;
1085 			}
1086 			con.ctype = np->type;
1087 			switch (classify(np->type)) {
1088 				case TINT:
1089 					con.crval = np->range[0];
1090 					break;
1091 				case TDOUBLE:
1092 					con.crval = np->real;
1093 					break;
1094 				case TBOOL:
1095 				case TCHAR:
1096 				case TSCAL:
1097 					con.cival = np->value[0];
1098 					con.crval = con.cival;
1099 					break;
1100 				case TSTR:
1101 					con.cpval = np->ptr[0];
1102 					break;
1103 				default:
1104 					con.ctype = NIL;
1105 					return FALSE;
1106 			}
1107 			break;
1108 		case T_BINT:
1109 			con.crval = a8tol(cn[2]);
1110 			goto restcon;
1111 		case T_INT:
1112 			con.crval = atof(cn[2]);
1113 			if (con.crval > MAXINT || con.crval < MININT) {
1114 				derror("Constant too large for this implementation");
1115 				con.crval = 0;
1116 			}
1117 restcon:
1118 			ci = con.crval;
1119 #ifndef PI0
1120 			if (bytes(ci, ci) <= 2)
1121 				con.ctype = nl+T2INT;
1122 			else
1123 #endif
1124 				con.ctype = nl+T4INT;
1125 			break;
1126 		case T_FINT:
1127 			con.ctype = nl+TDOUBLE;
1128 			con.crval = atof(cn[2]);
1129 			break;
1130 		case T_STRNG:
1131 			cp = cn[2];
1132 			if (cp[1] == 0) {
1133 				con.ctype = nl+T1CHAR;
1134 				con.cival = cp[0];
1135 				con.crval = con.cival;
1136 				break;
1137 			}
1138 			con.ctype = nl+TSTR;
1139 			con.cpval = cp;
1140 			break;
1141 	}
1142 	if (sgnd) {
1143 		if (isnta(con.ctype, "id")) {
1144 			derror("%s constants cannot be signed", nameof(con.ctype));
1145 			return FALSE;
1146 		} else if (negd)
1147 			con.crval = -con.crval;
1148 	}
1149 	return TRUE;
1150 }
1151