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