projects / unix-history / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
fix alias bug; count message sizes; map stderr->stdout; misc.
[unix-history] / usr / src / usr.bin / pascal / src / rval.c
CommitLineData
55839dac
PK		 1/* Copyright (c) 1979 Regents of the University of California */
2
70de7f21 3static char sccsid[] = "@(#)rval.c 1.4 %G%";
55839dac
PK		 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
15extern char *opnames[];
55839dac
PK		 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 */
45struct nl *
46rvalue(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
542a2aa0 89 putleaf( P2ICON , 0 , 0 , P2PTR|P2UNDEF , 0 );
55839dac
PK		 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 */
158ind:
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];
202cstrng:
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:
c4e911b6 306 case FFUNC:
55839dac
PK		 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:
c4e911b6 326 case FPROC:
55839dac
PK		 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 /*
70de7f21
PK		 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.
55839dac 493 */
70de7f21 494 if ( contype == NIL ) {
55839dac 495 codeoff();
70de7f21 496 contype = rvalue( r[3] , NIL , RREQ );
55839dac 497 codeon();
70de7f21
PK		 498 if ( contype == lookup( intset ) -> type ) {
499 codeoff();
500 contype = rvalue( r[2] , NIL , RREQ );
501 codeon();
502 }
55839dac 503 }
70de7f21
PK		 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;
55839dac
PK		 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 ] );
70de7f21
PK		 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 );
55839dac
PK		 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 );
70de7f21 583 p = rvalue( r[2] , contype , LREQ );
55839dac
PK		 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
70de7f21 669 if (p1->class == STR) {
55839dac
PK		 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);
70de7f21 682 if (width(p) > width(p1))
55839dac 683 contype = p;
70de7f21
PK		 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 }
55839dac
PK		 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 */
70de7f21 720 if ( c1 == TSTR ) {
55839dac
PK		 721 codeoff();
722 p = rvalue( r[ 2 ] , NIL , LREQ );
723 codeon();
70de7f21
PK		 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 }
55839dac
PK		 738 contype = p;
739 }
740 } else {
55839dac 741 contype = p;
55839dac
PK		 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
846clash:
847 error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname);
848 return (NIL);
849nonident:
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;
55839dac
PK		 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 ) ) {
70de7f21
PK		 870 putleaf( P2ICON , 0 , 0
871 , ADDTYPE( P2FTN | P2INT , P2PTR )
872 , "_IN" );
55839dac
PK		 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;
55839dac
PK		 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]);
949conint:
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 */
1013nocomp(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\f
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 */
1039constval(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;
1051loop:
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 }
1112restcon:
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}
Continuous source code history from original PDP-7 UNIX to FreeBSD 2, the first fully unencumbered FreeBSD release.