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