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