xref: /original-bsd/usr.bin/pascal/src/rval.c (revision 883fb6be) 
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.2 (Berkeley) 04/07/87";
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 #		ifdef tahoe
653 		    /* prepare for ediv workaround, see below. */
654 		    if (r->tag == T_MOD) {
655 			(void) rvalue(r->expr_node.lhs, NLNIL, RREQ);
656 			sconv(p2type(p), PCCT_INT);
657 		    }
658 #		endif tahoe
659 #		endif PC
660 		p1 = rvalue(r->expr_node.rhs, NLNIL , RREQ );
661 #		ifdef PC
662 		    sconv(p2type(p1), PCCT_INT);
663 #		endif PC
664 		if (p == NLNIL || p1 == NLNIL)
665 			return (NLNIL);
666 		if (isnta(p, "i")) {
667 			error("Left operand of %s must be integer, not %s", opname, nameof(p));
668 			return (NLNIL);
669 		}
670 		if (isnta(p1, "i")) {
671 			error("Right operand of %s must be integer, not %s", opname, nameof(p1));
672 			return (NLNIL);
673 		}
674 #		ifdef OBJ
675 		    return (gen(NIL, r->tag, width(p), width(p1)));
676 #		endif OBJ
677 #		ifdef PC
678 #		ifndef tahoe
679 		    putop( r->tag == T_DIV ? PCC_DIV : PCC_MOD , PCCT_INT );
680 		    return ( nl + T4INT );
681 #		else tahoe
682 		    putop( PCC_DIV , PCCT_INT );
683 		    if (r->tag == T_MOD) {
684 		    /*
685 		     * avoid f1 bug: PCC_MOD would generate an 'ediv',
686 		     * which would reuire too many registers to evaluate
687 		     * things like
688 		     * var i:boolean;j:integer; i := (j+1) = (j mod 2);
689 		     * so, instead of
690 		     *                PCC_MOD
691 		     *		        / \
692 		     *	               p   p1
693 		     * we put
694 		     *                  PCC_MINUS
695 		     *                    /   \
696 		     *			 p   PCC_MUL
697 		     *			      /   \
698 		     *			  PCC_DIV  p1
699 		     *                      / \
700 		     *                     p  p1
701 		     *
702 		     * we already have put p, p, p1, PCC_DIV. and now...
703 		     */
704 			    rvalue(r->expr_node.rhs, NLNIL , RREQ );
705 			    sconv(p2type(p1), PCCT_INT);
706 			    putop( PCC_MUL, PCCT_INT );
707 			    putop( PCC_MINUS, PCCT_INT );
708 		    }
709 		    return ( nl + T4INT );
710 #		endif tahoe
711 #		endif PC
712 
713 	case T_EQ:
714 	case T_NE:
715 	case T_LT:
716 	case T_GT:
717 	case T_LE:
718 	case T_GE:
719 		/*
720 		 * Since there can be no, a priori, knowledge
721 		 * of the context type should a constant string
722 		 * or set arise, we must poke around to find such
723 		 * a type if possible.  Since constant strings can
724 		 * always masquerade as identifiers, this is always
725 		 * necessary.
726 		 * see the note in the obj section of case T_MULT above
727 		 * for the determination of the base type of empty sets.
728 		 */
729 		codeoff();
730 		p1 = rvalue(r->expr_node.rhs, NLNIL , RREQ );
731 		codeon();
732 		if (p1 == NLNIL)
733 			return (NLNIL);
734 		contype = p1;
735 #		ifdef OBJ
736 		    if (p1->class == STR) {
737 			    /*
738 			     * For constant strings we want
739 			     * the longest type so as to be
740 			     * able to do padding (more importantly
741 			     * avoiding truncation). For clarity,
742 			     * we get this length here.
743 			     */
744 			    codeoff();
745 			    p = rvalue(r->expr_node.lhs, NLNIL , RREQ );
746 			    codeon();
747 			    if (p == NLNIL)
748 				    return (NLNIL);
749 			    if (width(p) > width(p1))
750 				    contype = p;
751 		    }
752 		    if (isa(p1, "t")) {
753 			codeoff();
754 			contype = rvalue(r->expr_node.lhs, p1, RREQ);
755 			codeon();
756 			if (contype == NLNIL) {
757 			    return NLNIL;
758 			}
759 		    }
760 		    /*
761 		     * Now we generate code for
762 		     * the operands of the relational
763 		     * operation.
764 		     */
765 		    p = rvalue(r->expr_node.lhs, contype , RREQ );
766 		    if (p == NLNIL)
767 			    return (NLNIL);
768 		    p1 = rvalue(r->expr_node.rhs, p , RREQ );
769 		    if (p1 == NLNIL)
770 			    return (NLNIL);
771 #		endif OBJ
772 #		ifdef PC
773 		    c1 = classify( p1 );
774 		    if ( c1 == TSET || c1 == TSTR || c1 == TREC ) {
775 			putleaf( PCC_ICON , 0 , 0
776 				, PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
777 				, c1 == TSET  ? relts[ r->tag - T_EQ ]
778 					      : relss[ r->tag - T_EQ ] );
779 			    /*
780 			     *	for [] and strings, comparisons are done on
781 			     *	the maximum width of the two sides.
782 			     *	for other sets, we have to ask the left side
783 			     *	what type it is based on the type of the right.
784 			     *	(this matters for intsets).
785 			     */
786 			if ( c1 == TSTR ) {
787 			    codeoff();
788 			    p = rvalue( r->expr_node.lhs , NLNIL , LREQ );
789 			    codeon();
790 			    if ( p == NLNIL ) {
791 				return NLNIL;
792 			    }
793 			    if ( lwidth( p ) > lwidth( p1 ) ) {
794 				contype = p;
795 			    }
796 			} else if ( c1 == TSET ) {
797 			    codeoff();
798 			    contype = rvalue(r->expr_node.lhs, p1, LREQ);
799 			    codeon();
800 			    if (contype == NLNIL) {
801 				return NLNIL;
802 			    }
803 			}
804 			    /*
805 			     *	put out the width of the comparison.
806 			     */
807 			putleaf(PCC_ICON, (int) lwidth(contype), 0, PCCT_INT, (char *) 0);
808 			    /*
809 			     *	and the left hand side,
810 			     *	for sets, strings, records
811 			     */
812 			p = rvalue( r->expr_node.lhs , contype , LREQ );
813 			if ( p == NLNIL ) {
814 			    return NLNIL;
815 			}
816 			putop( PCC_CM , PCCT_INT );
817 			p1 = rvalue( r->expr_node.rhs , p , LREQ );
818 			if ( p1 == NLNIL ) {
819 			    return NLNIL;
820 			}
821 			putop( PCC_CM , PCCT_INT );
822 			putop( PCC_CALL , PCCT_INT );
823 		    } else {
824 			    /*
825 			     *	the easy (scalar or error) case
826 			     */
827 			p = rvalue( r->expr_node.lhs , contype , RREQ );
828 			if ( p == NLNIL ) {
829 			    return NLNIL;
830 			}
831 			    /*
832 			     * since the second pass can't do
833 			     *	long op double  or  double op long
834 			     * we may have to do some coercing.
835 			     */
836 			tuac(p, p1, &rettype, (int *) (&ctype));
837 			p1 = rvalue( r->expr_node.rhs , p , RREQ );
838 			if ( p1 == NLNIL ) {
839 			    return NLNIL;
840 			}
841 			tuac(p1, p, &rettype, (int *) (&ctype));
842 			putop((int) relops[ r->tag - T_EQ ] , PCCT_INT );
843 			sconv(PCCT_INT, PCCT_CHAR);
844 		    }
845 #		endif PC
846 		c = classify(p);
847 		c1 = classify(p1);
848 		if (nocomp(c) || nocomp(c1))
849 			return (NLNIL);
850 #		ifdef OBJ
851 		    g = NIL;
852 #		endif
853 		switch (c) {
854 			case TBOOL:
855 			case TCHAR:
856 				if (c != c1)
857 					goto clash;
858 				break;
859 			case TINT:
860 			case TDOUBLE:
861 				if (c1 != TINT && c1 != TDOUBLE)
862 					goto clash;
863 				break;
864 			case TSCAL:
865 				if (c1 != TSCAL)
866 					goto clash;
867 				if (scalar(p) != scalar(p1))
868 					goto nonident;
869 				break;
870 			case TSET:
871 				if (c1 != TSET)
872 					goto clash;
873 				if ( opt( 's' ) &&
874 				    ( ( r->tag == T_LT) || (r->tag == T_GT) ) &&
875 				    ( line != nssetline ) ) {
876 				    nssetline = line;
877 				    standard();
878 				    error("%s comparison on sets is non-standard" , opname );
879 				}
880 				if (p != p1)
881 					goto nonident;
882 #				ifdef OBJ
883 				    g = TSET;
884 #				endif
885 				break;
886 			case TREC:
887 				if ( c1 != TREC ) {
888 				    goto clash;
889 				}
890 				if ( p != p1 ) {
891 				    goto nonident;
892 				}
893 				if (r->tag != T_EQ && r->tag != T_NE) {
894 					error("%s not allowed on records - only allow = and <>" , opname );
895 					return (NLNIL);
896 				}
897 #				ifdef OBJ
898 				    g = TREC;
899 #				endif
900 				break;
901 			case TPTR:
902 			case TNIL:
903 				if (c1 != TPTR && c1 != TNIL)
904 					goto clash;
905 				if (r->tag != T_EQ && r->tag != T_NE) {
906 					error("%s not allowed on pointers - only allow = and <>" , opname );
907 					return (NLNIL);
908 				}
909 				if (p != nl+TNIL && p1 != nl+TNIL && p != p1)
910 					goto nonident;
911 				break;
912 			case TSTR:
913 				if (c1 != TSTR)
914 					goto clash;
915 				if (width(p) != width(p1)) {
916 					error("Strings not same length in %s comparison", opname);
917 					return (NLNIL);
918 				}
919 #				ifdef OBJ
920 				    g = TSTR;
921 #				endif OBJ
922 				break;
923 			default:
924 				panic("rval2");
925 		}
926 #		ifdef OBJ
927 		    return (gen(g, r->tag, width(p), width(p1)));
928 #		endif OBJ
929 #		ifdef PC
930 		    return nl + TBOOL;
931 #		endif PC
932 clash:
933 		error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname);
934 		return (NLNIL);
935 nonident:
936 		error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname);
937 		return (NLNIL);
938 
939 	case T_IN:
940 	    rt = r->expr_node.rhs;
941 #	    ifdef OBJ
942 		if (rt != TR_NIL && rt->tag == T_CSET) {
943 			(void) precset( rt , NLNIL , &csetd );
944 			p1 = csetd.csettype;
945 			if (p1 == NLNIL)
946 			    return NLNIL;
947 			postcset( rt, &csetd);
948 		    } else {
949 			p1 = stkrval(r->expr_node.rhs, NLNIL , (long) RREQ );
950 			rt = TR_NIL;
951 		    }
952 #		endif OBJ
953 #		ifdef PC
954 		    if (rt != TR_NIL && rt->tag == T_CSET) {
955 			if ( precset( rt , NLNIL , &csetd ) ) {
956 			    putleaf( PCC_ICON , 0 , 0
957 				    , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
958 				    , "_IN" );
959 			} else {
960 			    putleaf( PCC_ICON , 0 , 0
961 				    , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
962 				    , "_INCT" );
963 			}
964 			p1 = csetd.csettype;
965 			if (p1 == NIL)
966 			    return NLNIL;
967 		    } else {
968 			putleaf( PCC_ICON , 0 , 0
969 				, PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
970 				, "_IN" );
971 			codeoff();
972 			p1 = rvalue(r->expr_node.rhs, NLNIL , LREQ );
973 			codeon();
974 		    }
975 #		endif PC
976 		p = stkrval(r->expr_node.lhs, NLNIL , (long) RREQ );
977 		if (p == NIL || p1 == NIL)
978 			return (NLNIL);
979 		if (p1->class != (char) SET) {
980 			error("Right operand of 'in' must be a set, not %s", nameof(p1));
981 			return (NLNIL);
982 		}
983 		if (incompat(p, p1->type, r->expr_node.lhs)) {
984 			cerror("Index type clashed with set component type for 'in'");
985 			return (NLNIL);
986 		}
987 		setran(p1->type);
988 #		ifdef OBJ
989 		    if (rt == TR_NIL || csetd.comptime)
990 			    (void) put(4, O_IN, width(p1), set.lwrb, set.uprbp);
991 		    else
992 			    (void) put(2, O_INCT,
993 				(int)(3 + csetd.singcnt + 2*csetd.paircnt));
994 #		endif OBJ
995 #		ifdef PC
996 		    if ( rt == TR_NIL || rt->tag != T_CSET ) {
997 			putleaf( PCC_ICON , set.lwrb , 0 , PCCT_INT , (char *) 0 );
998 			putop( PCC_CM , PCCT_INT );
999 			putleaf( PCC_ICON , set.uprbp , 0 , PCCT_INT , (char *) 0 );
1000 			putop( PCC_CM , PCCT_INT );
1001 			p1 = rvalue( r->expr_node.rhs , NLNIL , LREQ );
1002 			if ( p1 == NLNIL ) {
1003 			    return NLNIL;
1004 			}
1005 			putop( PCC_CM , PCCT_INT );
1006 		    } else if ( csetd.comptime ) {
1007 			putleaf( PCC_ICON , set.lwrb , 0 , PCCT_INT , (char *) 0 );
1008 			putop( PCC_CM , PCCT_INT );
1009 			putleaf( PCC_ICON , set.uprbp , 0 , PCCT_INT , (char *) 0 );
1010 			putop( PCC_CM , PCCT_INT );
1011 			postcset( r->expr_node.rhs , &csetd );
1012 			putop( PCC_CM , PCCT_INT );
1013 		    } else {
1014 			postcset( r->expr_node.rhs , &csetd );
1015 		    }
1016 		    putop( PCC_CALL , PCCT_INT );
1017 		    sconv(PCCT_INT, PCCT_CHAR);
1018 #		endif PC
1019 		return (nl+T1BOOL);
1020 	default:
1021 		if (r->expr_node.lhs == TR_NIL)
1022 			return (NLNIL);
1023 		switch (r->tag) {
1024 		default:
1025 			panic("rval3");
1026 
1027 
1028 		/*
1029 		 * An octal number
1030 		 */
1031 		case T_BINT:
1032 			f.pdouble = a8tol(r->const_node.cptr);
1033 			goto conint;
1034 
1035 		/*
1036 		 * A decimal number
1037 		 */
1038 		case T_INT:
1039 			f.pdouble = atof(r->const_node.cptr);
1040 conint:
1041 			if (f.pdouble > MAXINT || f.pdouble < MININT) {
1042 				error("Constant too large for this implementation");
1043 				return (NLNIL);
1044 			}
1045 			l = f.pdouble;
1046 #			ifdef OBJ
1047 			    if (bytes(l, l) <= 2) {
1048 				    (void) put(2, O_CON2, ( short ) l);
1049 				    return (nl+T2INT);
1050 			    }
1051 			    (void) put(2, O_CON4, l);
1052 			    return (nl+T4INT);
1053 #			endif OBJ
1054 #			ifdef PC
1055 			    switch (bytes(l, l)) {
1056 				case 1:
1057 				    putleaf(PCC_ICON, (int) l, 0, PCCT_CHAR,
1058 						(char *) 0);
1059 				    return nl+T1INT;
1060 				case 2:
1061 				    putleaf(PCC_ICON, (int) l, 0, PCCT_SHORT,
1062 						(char *) 0);
1063 				    return nl+T2INT;
1064 				case 4:
1065 				    putleaf(PCC_ICON, (int) l, 0, PCCT_INT,
1066 						(char *) 0);
1067 				    return nl+T4INT;
1068 			    }
1069 #			endif PC
1070 
1071 		/*
1072 		 * A floating point number
1073 		 */
1074 		case T_FINT:
1075 #			ifdef OBJ
1076 			    (void) put(2, O_CON8, atof(r->const_node.cptr));
1077 #			endif OBJ
1078 #			ifdef PC
1079 			    putCON8( atof( r->const_node.cptr ) );
1080 #			endif PC
1081 			return (nl+TDOUBLE);
1082 
1083 		/*
1084 		 * Constant strings.  Note that constant characters
1085 		 * are constant strings of length one; there is
1086 		 * no constant string of length one.
1087 		 */
1088 		case T_STRNG:
1089 			cp = r->const_node.cptr;
1090 			if (cp[1] == 0) {
1091 #				ifdef OBJ
1092 				    (void) put(2, O_CONC, cp[0]);
1093 #				endif OBJ
1094 #				ifdef PC
1095 				    putleaf( PCC_ICON , cp[0] , 0 , PCCT_CHAR ,
1096 						(char *) 0 );
1097 #				endif PC
1098 				return (nl+T1CHAR);
1099 			}
1100 			goto cstrng;
1101 		}
1102 
1103 	}
1104 }
1105 
1106 /*
1107  * Can a class appear
1108  * in a comparison ?
1109  */
1110 nocomp(c)
1111 	int c;
1112 {
1113 
1114 	switch (c) {
1115 		case TREC:
1116 			if ( line != reccompline ) {
1117 			    reccompline = line;
1118 			    warning();
1119 			    if ( opt( 's' ) ) {
1120 				standard();
1121 			    }
1122 			    error("record comparison is non-standard");
1123 			}
1124 			break;
1125 		case TFILE:
1126 		case TARY:
1127 			error("%ss may not participate in comparisons", clnames[c]);
1128 			return (1);
1129 	}
1130 	return (NIL);
1131 }
1132 
1133     /*
1134      *	this is sort of like gconst, except it works on expression trees
1135      *	rather than declaration trees, and doesn't give error messages for
1136      *	non-constant things.
1137      *	as a side effect this fills in the con structure that gconst uses.
1138      *	this returns TRUE or FALSE.
1139      */
1140 
1141 bool
1142 constval(r)
1143 	register struct tnode *r;
1144 {
1145 	register struct nl *np;
1146 	register struct tnode *cn;
1147 	char *cp;
1148 	int negd, sgnd;
1149 	long ci;
1150 
1151 	con.ctype = NIL;
1152 	cn = r;
1153 	negd = sgnd = 0;
1154 loop:
1155 	    /*
1156 	     *	cn[2] is nil if error recovery generated a T_STRNG
1157 	     */
1158 	if (cn == TR_NIL || cn->expr_node.lhs == TR_NIL)
1159 		return FALSE;
1160 	switch (cn->tag) {
1161 		default:
1162 			return FALSE;
1163 		case T_MINUS:
1164 			negd = 1 - negd;
1165 			/* and fall through */
1166 		case T_PLUS:
1167 			sgnd++;
1168 			cn = cn->un_expr.expr;
1169 			goto loop;
1170 		case T_NIL:
1171 			con.cpval = NIL;
1172 			con.cival = 0;
1173 			con.crval = con.cival;
1174 			con.ctype = nl + TNIL;
1175 			break;
1176 		case T_VAR:
1177 			np = lookup(cn->var_node.cptr);
1178 			if (np == NLNIL || np->class != CONST) {
1179 				return FALSE;
1180 			}
1181 			if ( cn->var_node.qual != TR_NIL ) {
1182 				return FALSE;
1183 			}
1184 			con.ctype = np->type;
1185 			switch (classify(np->type)) {
1186 				case TINT:
1187 					con.crval = np->range[0];
1188 					break;
1189 				case TDOUBLE:
1190 					con.crval = np->real;
1191 					break;
1192 				case TBOOL:
1193 				case TCHAR:
1194 				case TSCAL:
1195 					con.cival = np->value[0];
1196 					con.crval = con.cival;
1197 					break;
1198 				case TSTR:
1199 					con.cpval = (char *) np->ptr[0];
1200 					break;
1201 				default:
1202 					con.ctype = NIL;
1203 					return FALSE;
1204 			}
1205 			break;
1206 		case T_BINT:
1207 			con.crval = a8tol(cn->const_node.cptr);
1208 			goto restcon;
1209 		case T_INT:
1210 			con.crval = atof(cn->const_node.cptr);
1211 			if (con.crval > MAXINT || con.crval < MININT) {
1212 				derror("Constant too large for this implementation");
1213 				con.crval = 0;
1214 			}
1215 restcon:
1216 			ci = con.crval;
1217 #ifndef PI0
1218 			if (bytes(ci, ci) <= 2)
1219 				con.ctype = nl+T2INT;
1220 			else
1221 #endif
1222 				con.ctype = nl+T4INT;
1223 			break;
1224 		case T_FINT:
1225 			con.ctype = nl+TDOUBLE;
1226 			con.crval = atof(cn->const_node.cptr);
1227 			break;
1228 		case T_STRNG:
1229 			cp = cn->const_node.cptr;
1230 			if (cp[1] == 0) {
1231 				con.ctype = nl+T1CHAR;
1232 				con.cival = cp[0];
1233 				con.crval = con.cival;
1234 				break;
1235 			}
1236 			con.ctype = nl+TSTR;
1237 			con.cpval = cp;
1238 			break;
1239 	}
1240 	if (sgnd) {
1241 		if (isnta(con.ctype, "id")) {
1242 			derror("%s constants cannot be signed", nameof(con.ctype));
1243 			return FALSE;
1244 		} else if (negd)
1245 			con.crval = -con.crval;
1246 	}
1247 	return TRUE;
1248 }
1249