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