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