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