projects / unix-history / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
MACHK, KSPNOTVAL, CHM? panics, not halts
[unix-history] / usr / src / usr.bin / pascal / src / rval.c
CommitLineData
55839dac
PK		 1/* Copyright (c) 1979 Regents of the University of California */
2
3static char sccsid[] = "@(#)rval.c 1.1 %G%";
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:
307 /*
308 * Function call with no arguments.
309 */
310 if (r[3]) {
311 error("Can't qualify a function result value");
312 return (NIL);
313 }
314# ifdef OBJ
315 return (funccod((int *) r));
316# endif OBJ
317# ifdef PC
318 return (pcfunccod( r ));
319# endif PC
320
321 case TYPE:
322 error("Type names (e.g. %s) allowed only in declarations", p->symbol);
323 return (NIL);
324
325 case PROC:
326 error("Procedure %s found where expression required", p->symbol);
327 return (NIL);
328 default:
329 panic("rvid");
330 }
331 /*
332 * Constant sets
333 */
334 case T_CSET:
335# ifdef OBJ
336 if ( precset( r , contype , &csetd ) ) {
337 if ( csetd.csettype == NIL ) {
338 return NIL;
339 }
340 postcset( r , &csetd );
341 } else {
342 put( 2, O_PUSH, -width(csetd.csettype));
343 postcset( r , &csetd );
344 setran( ( csetd.csettype ) -> type );
345 put( 2, O_CON24, set.uprbp);
346 put( 2, O_CON24, set.lwrb);
347 put( 2, O_CTTOT, 5 + csetd.singcnt + 2 * csetd.paircnt);
348 }
349 return csetd.csettype;
350# endif OBJ
351# ifdef PC
352 if ( precset( r , contype , &csetd ) ) {
353 if ( csetd.csettype == NIL ) {
354 return NIL;
355 }
356 postcset( r , &csetd );
357 } else {
358 putleaf( P2ICON , 0 , 0
359 , ADDTYPE( P2FTN | P2INT , P2PTR )
360 , "_CTTOT" );
361 /*
362 * allocate a temporary and use it
363 */
364 sizes[ cbn ].om_off -= lwidth( csetd.csettype );
365 tempoff = sizes[ cbn ].om_off;
366 putlbracket( ftnno , -tempoff );
367 if ( tempoff < sizes[ cbn ].om_max ) {
368 sizes[ cbn ].om_max = tempoff;
369 }
370 putLV( 0 , cbn , tempoff , P2PTR|P2STRTY );
371 setran( ( csetd.csettype ) -> type );
372 putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 );
373 putop( P2LISTOP , P2INT );
374 putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 );
375 putop( P2LISTOP , P2INT );
376 postcset( r , &csetd );
377 putop( P2CALL , P2INT );
378 }
379 return csetd.csettype;
380# endif PC
381
382 /*
383 * Unary plus and minus
384 */
385 case T_PLUS:
386 case T_MINUS:
387 q = rvalue(r[2], NIL , RREQ );
388 if (q == NIL)
389 return (NIL);
390 if (isnta(q, "id")) {
391 error("Operand of %s must be integer or real, not %s", opname, nameof(q));
392 return (NIL);
393 }
394 if (r[0] == T_MINUS) {
395# ifdef OBJ
396 put(1, O_NEG2 + (width(q) >> 2));
397# endif OBJ
398# ifdef PC
399 putop( P2UNARY P2MINUS , p2type( q ) );
400# endif PC
401 return (isa(q, "d") ? q : nl+T4INT);
402 }
403 return (q);
404
405 case T_NOT:
406 q = rvalue(r[2], NIL , RREQ );
407 if (q == NIL)
408 return (NIL);
409 if (isnta(q, "b")) {
410 error("not must operate on a Boolean, not %s", nameof(q));
411 return (NIL);
412 }
413# ifdef OBJ
414 put(1, O_NOT);
415# endif OBJ
416# ifdef PC
417 putop( P2NOT , P2INT );
418# endif PC
419 return (nl+T1BOOL);
420
421 case T_AND:
422 case T_OR:
423 p = rvalue(r[2], NIL , RREQ );
424 p1 = rvalue(r[3], NIL , RREQ );
425 if (p == NIL || p1 == NIL)
426 return (NIL);
427 if (isnta(p, "b")) {
428 error("Left operand of %s must be Boolean, not %s", opname, nameof(p));
429 return (NIL);
430 }
431 if (isnta(p1, "b")) {
432 error("Right operand of %s must be Boolean, not %s", opname, nameof(p1));
433 return (NIL);
434 }
435# ifdef OBJ
436 put(1, r[0] == T_AND ? O_AND : O_OR);
437# endif OBJ
438# ifdef PC
439 /*
440 * note the use of & and | rather than && and ||
441 * to force evaluation of all the expressions.
442 */
443 putop( r[ 0 ] == T_AND ? P2AND : P2OR , P2INT );
444# endif PC
445 return (nl+T1BOOL);
446
447 case T_DIVD:
448# ifdef OBJ
449 p = rvalue(r[2], NIL , RREQ );
450 p1 = rvalue(r[3], NIL , RREQ );
451# endif OBJ
452# ifdef PC
453 /*
454 * force these to be doubles for the divide
455 */
456 p = rvalue( r[ 2 ] , NIL , RREQ );
457 if ( isnta( p , "d" ) ) {
458 putop( P2SCONV , P2DOUBLE );
459 }
460 p1 = rvalue( r[ 3 ] , NIL , RREQ );
461 if ( isnta( p1 , "d" ) ) {
462 putop( P2SCONV , P2DOUBLE );
463 }
464# endif PC
465 if (p == NIL || p1 == NIL)
466 return (NIL);
467 if (isnta(p, "id")) {
468 error("Left operand of / must be integer or real, not %s", nameof(p));
469 return (NIL);
470 }
471 if (isnta(p1, "id")) {
472 error("Right operand of / must be integer or real, not %s", nameof(p1));
473 return (NIL);
474 }
475# ifdef OBJ
476 return gen(NIL, r[0], width(p), width(p1));
477# endif OBJ
478# ifdef PC
479 putop( P2DIV , P2DOUBLE );
480 return nl + TDOUBLE;
481# endif PC
482
483 case T_MULT:
484 case T_ADD:
485 case T_SUB:
486# ifdef OBJ
487 /*
488 * If the context hasn't told us
489 * the type and a constant set is
490 * present on the left we need to infer
491 * the type from the right if possible
492 * before generating left side code.
493 */
494 if (contype == NIL && (rt = r[2]) != NIL && rt[1] == SAWCON) {
495 codeoff();
496 contype = rvalue(r[3], NIL , RREQ );
497 codeon();
498 if (contype == NIL)
499 return (NIL);
500 }
501 p = rvalue(r[2], contype , RREQ );
502 p1 = rvalue(r[3], p , RREQ );
503 if (p == NIL || p1 == NIL)
504 return (NIL);
505 if (isa(p, "id") && isa(p1, "id"))
506 return (gen(NIL, r[0], width(p), width(p1)));
507 if (isa(p, "t") && isa(p1, "t")) {
508 if (p != p1) {
509 error("Set types of operands of %s must be identical", opname);
510 return (NIL);
511 }
512 gen(TSET, r[0], width(p), 0);
513 return (p);
514 }
515# endif OBJ
516# ifdef PC
517 /*
518 * the second pass can't do
519 * long op double or double op long
520 * so we have to know the type of both operands
521 * also, it gets tricky for sets, which are done
522 * by function calls.
523 */
524 codeoff();
525 p1 = rvalue( r[ 3 ] , contype , RREQ );
526 codeon();
527 if ( isa( p1 , "id" ) ) {
528 p = rvalue( r[ 2 ] , contype , RREQ );
529 if ( ( p == NIL ) || ( p1 == NIL ) ) {
530 return NIL;
531 }
532 if ( isa( p , "i" ) && isa( p1 , "d" ) ) {
533 putop( P2SCONV , P2DOUBLE );
534 }
535 p1 = rvalue( r[ 3 ] , contype , RREQ );
536 if ( isa( p , "d" ) && isa( p1 , "i" ) ) {
537 putop( P2SCONV , P2DOUBLE );
538 }
539 if ( isa( p , "id" ) ) {
540 if ( isa( p , "d" ) || isa( p1 , "d" ) ) {
541 ctype = P2DOUBLE;
542 rettype = nl + TDOUBLE;
543 } else {
544 ctype = P2INT;
545 rettype = nl + T4INT;
546 }
547 putop( mathop[ r[0] - T_MULT ] , ctype );
548 return rettype;
549 }
550 }
551 if ( isa( p1 , "t" ) ) {
552 putleaf( P2ICON , 0 , 0
553 , ADDTYPE( ADDTYPE( P2PTR | P2STRTY , P2FTN )
554 , P2PTR )
555 , setop[ r[0] - T_MULT ] );
556 /*
557 * allocate a temporary and use it
558 */
559 sizes[ cbn ].om_off -= lwidth( p1 );
560 tempoff = sizes[ cbn ].om_off;
561 putlbracket( ftnno , -tempoff );
562 if ( tempoff < sizes[ cbn ].om_max ) {
563 sizes[ cbn ].om_max = tempoff;
564 }
565 putLV( 0 , cbn , tempoff , P2PTR|P2STRTY );
566 p = rvalue( r[2] , p1 , LREQ );
567 if ( isa( p , "t" ) ) {
568 putop( P2LISTOP , P2INT );
569 if ( p == NIL || p1 == NIL ) {
570 return NIL;
571 }
572 p1 = rvalue( r[3] , p , LREQ );
573 if ( p != p1 ) {
574 error("Set types of operands of %s must be identical", opname);
575 return NIL;
576 }
577 putop( P2LISTOP , P2INT );
578 putleaf( P2ICON , lwidth( p1 ) / sizeof( long ) , 0
579 , P2INT , 0 );
580 putop( P2LISTOP , P2INT );
581 putop( P2CALL , P2PTR | P2STRTY );
582 return p;
583 }
584 }
585 if ( isnta( p1 , "idt" ) ) {
586 /*
587 * find type of left operand for error message.
588 */
589 p = rvalue( r[2] , contype , RREQ );
590 }
591 /*
592 * don't give spurious error messages.
593 */
594 if ( p == NIL || p1 == NIL ) {
595 return NIL;
596 }
597# endif PC
598 if (isnta(p, "idt")) {
599 error("Left operand of %s must be integer, real or set, not %s", opname, nameof(p));
600 return (NIL);
601 }
602 if (isnta(p1, "idt")) {
603 error("Right operand of %s must be integer, real or set, not %s", opname, nameof(p1));
604 return (NIL);
605 }
606 error("Cannot mix sets with integers and reals as operands of %s", opname);
607 return (NIL);
608
609 case T_MOD:
610 case T_DIV:
611 p = rvalue(r[2], NIL , RREQ );
612 p1 = rvalue(r[3], NIL , RREQ );
613 if (p == NIL || p1 == NIL)
614 return (NIL);
615 if (isnta(p, "i")) {
616 error("Left operand of %s must be integer, not %s", opname, nameof(p));
617 return (NIL);
618 }
619 if (isnta(p1, "i")) {
620 error("Right operand of %s must be integer, not %s", opname, nameof(p1));
621 return (NIL);
622 }
623# ifdef OBJ
624 return (gen(NIL, r[0], width(p), width(p1)));
625# endif OBJ
626# ifdef PC
627 putop( r[ 0 ] == T_DIV ? P2DIV : P2MOD , P2INT );
628 return ( nl + T4INT );
629# endif PC
630
631 case T_EQ:
632 case T_NE:
633 case T_LT:
634 case T_GT:
635 case T_LE:
636 case T_GE:
637 /*
638 * Since there can be no, a priori, knowledge
639 * of the context type should a constant string
640 * or set arise, we must poke around to find such
641 * a type if possible. Since constant strings can
642 * always masquerade as identifiers, this is always
643 * necessary.
644 */
645 codeoff();
646 p1 = rvalue(r[3], NIL , RREQ );
647 codeon();
648 if (p1 == NIL)
649 return (NIL);
650 contype = p1;
651# ifdef OBJ
652 if (p1 == nl+TSET || p1->class == STR) {
653 /*
654 * For constant strings we want
655 * the longest type so as to be
656 * able to do padding (more importantly
657 * avoiding truncation). For clarity,
658 * we get this length here.
659 */
660 codeoff();
661 p = rvalue(r[2], NIL , RREQ );
662 codeon();
663 if (p == NIL)
664 return (NIL);
665 if (p1 == nl+TSET || width(p) > width(p1))
666 contype = p;
667 }
668 /*
669 * Now we generate code for
670 * the operands of the relational
671 * operation.
672 */
673 p = rvalue(r[2], contype , RREQ );
674 if (p == NIL)
675 return (NIL);
676 p1 = rvalue(r[3], p , RREQ );
677 if (p1 == NIL)
678 return (NIL);
679# endif OBJ
680# ifdef PC
681 c1 = classify( p1 );
682 if ( c1 == TSET || c1 == TSTR || c1 == TREC ) {
683 putleaf( P2ICON , 0 , 0
684 , ADDTYPE( P2FTN | P2INT , P2PTR )
685 , c1 == TSET ? relts[ r[0] - T_EQ ]
686 : relss[ r[0] - T_EQ ] );
687 /*
688 * for [] and strings, comparisons are done on
689 * the maximum width of the two sides.
690 * for other sets, we have to ask the left side
691 * what type it is based on the type of the right.
692 * (this matters for intsets).
693 */
694 if ( p1 == nl + TSET || c1 == TSTR ) {
695 codeoff();
696 p = rvalue( r[ 2 ] , NIL , LREQ );
697 codeon();
698 if ( p1 == nl + TSET
699 || lwidth( p ) > lwidth( p1 ) ) {
700 contype = p;
701 }
702 } else {
703 codeoff();
704 p = rvalue( r[ 2 ] , contype , LREQ );
705 codeon();
706 contype = p;
707 }
708 if ( p == NIL ) {
709 return NIL;
710 }
711 /*
712 * put out the width of the comparison.
713 */
714 putleaf( P2ICON , lwidth( contype ) , 0 , P2INT , 0 );
715 /*
716 * and the left hand side,
717 * for sets, strings, records
718 */
719 p = rvalue( r[ 2 ] , contype , LREQ );
720 putop( P2LISTOP , P2INT );
721 p1 = rvalue( r[ 3 ] , p , LREQ );
722 putop( P2LISTOP , P2INT );
723 putop( P2CALL , P2INT );
724 } else {
725 /*
726 * the easy (scalar or error) case
727 */
728 p = rvalue( r[ 2 ] , contype , RREQ );
729 if ( p == NIL ) {
730 return NIL;
731 /*
732 * since the second pass can't do
733 * long op double or double op long
734 * we may have to do some coercing.
735 */
736 if ( isa( p , "i" ) && isa( p1 , "d" ) )
737 putop( P2SCONV , P2DOUBLE );
738 }
739 p1 = rvalue( r[ 3 ] , p , RREQ );
740 if ( isa( p , "d" ) && isa( p1 , "i" ) )
741 putop( P2SCONV , P2DOUBLE );
742 putop( relops[ r[0] - T_EQ ] , P2INT );
743 }
744# endif PC
745 c = classify(p);
746 c1 = classify(p1);
747 if (nocomp(c) || nocomp(c1))
748 return (NIL);
749 g = NIL;
750 switch (c) {
751 case TBOOL:
752 case TCHAR:
753 if (c != c1)
754 goto clash;
755 break;
756 case TINT:
757 case TDOUBLE:
758 if (c1 != TINT && c1 != TDOUBLE)
759 goto clash;
760 break;
761 case TSCAL:
762 if (c1 != TSCAL)
763 goto clash;
764 if (scalar(p) != scalar(p1))
765 goto nonident;
766 break;
767 case TSET:
768 if (c1 != TSET)
769 goto clash;
770 if (p != p1)
771 goto nonident;
772 g = TSET;
773 break;
774 case TREC:
775 if ( c1 != TREC ) {
776 goto clash;
777 }
778 if ( p != p1 ) {
779 goto nonident;
780 }
781 if (r[0] != T_EQ && r[0] != T_NE) {
782 error("%s not allowed on records - only allow = and <>" , opname );
783 return (NIL);
784 }
785 g = TREC;
786 break;
787 case TPTR:
788 case TNIL:
789 if (c1 != TPTR && c1 != TNIL)
790 goto clash;
791 if (r[0] != T_EQ && r[0] != T_NE) {
792 error("%s not allowed on pointers - only allow = and <>" , opname );
793 return (NIL);
794 }
795 break;
796 case TSTR:
797 if (c1 != TSTR)
798 goto clash;
799 if (width(p) != width(p1)) {
800 error("Strings not same length in %s comparison", opname);
801 return (NIL);
802 }
803 g = TSTR;
804 break;
805 default:
806 panic("rval2");
807 }
808# ifdef OBJ
809 return (gen(g, r[0], width(p), width(p1)));
810# endif OBJ
811# ifdef PC
812 return nl + TBOOL;
813# endif PC
814clash:
815 error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname);
816 return (NIL);
817nonident:
818 error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname);
819 return (NIL);
820
821 case T_IN:
822 rt = r[3];
823# ifdef OBJ
824 if (rt != NIL && rt[0] == T_CSET) {
825 precset( rt , NIL , &csetd );
826 p1 = csetd.csettype;
827 if (p1 == NIL)
828 return NIL;
829 if (p1 == nl+TSET) {
830 if ( !inempty ) {
831 warning();
832 error("... in [] makes little sense, since it is always false!");
833 inempty = TRUE;
834 }
835 put(1, O_CON1, 0);
836 return (nl+T1BOOL);
837 }
838 postcset( rt, &csetd);
839 } else {
840 p1 = stkrval(r[3], NIL , RREQ );
841 rt = NIL;
842 }
843# endif OBJ
844# ifdef PC
845 if (rt != NIL && rt[0] == T_CSET) {
846 if ( precset( rt , NIL , &csetd ) ) {
847 if ( csetd.csettype != nl + TSET ) {
848 putleaf( P2ICON , 0 , 0
849 , ADDTYPE( P2FTN | P2INT , P2PTR )
850 , "_IN" );
851 }
852 } else {
853 putleaf( P2ICON , 0 , 0
854 , ADDTYPE( P2FTN | P2INT , P2PTR )
855 , "_INCT" );
856 }
857 p1 = csetd.csettype;
858 if (p1 == NIL)
859 return NIL;
860 if ( p1 == nl + TSET ) {
861 if ( !inempty ) {
862 warning();
863 error("... in [] makes little sense, since it is always false!");
864 inempty = TRUE;
865 }
866 putleaf( P2ICON , 0 , 0 , P2INT , 0 );
867 return (nl+T1BOOL);
868 }
869 } else {
870 putleaf( P2ICON , 0 , 0
871 , ADDTYPE( P2FTN | P2INT , P2PTR )
872 , "_IN" );
873 codeoff();
874 p1 = rvalue(r[3], NIL , LREQ );
875 codeon();
876 }
877# endif PC
878 p = stkrval(r[2], NIL , RREQ );
879 if (p == NIL || p1 == NIL)
880 return (NIL);
881 if (p1->class != SET) {
882 error("Right operand of 'in' must be a set, not %s", nameof(p1));
883 return (NIL);
884 }
885 if (incompat(p, p1->type, r[2])) {
886 cerror("Index type clashed with set component type for 'in'");
887 return (NIL);
888 }
889 setran(p1->type);
890# ifdef OBJ
891 if (rt == NIL || csetd.comptime)
892 put(4, O_IN, width(p1), set.lwrb, set.uprbp);
893 else
894 put(2, O_INCT, 3 + csetd.singcnt + 2*csetd.paircnt);
895# endif OBJ
896# ifdef PC
897 if ( rt == NIL || rt[0] != T_CSET ) {
898 putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 );
899 putop( P2LISTOP , P2INT );
900 putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 );
901 putop( P2LISTOP , P2INT );
902 p1 = rvalue( r[3] , NIL , LREQ );
903 putop( P2LISTOP , P2INT );
904 } else if ( csetd.comptime ) {
905 putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 );
906 putop( P2LISTOP , P2INT );
907 putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 );
908 putop( P2LISTOP , P2INT );
909 postcset( r[3] , &csetd );
910 putop( P2LISTOP , P2INT );
911 } else {
912 postcset( r[3] , &csetd );
913 }
914 putop( P2CALL , P2INT );
915# endif PC
916 return (nl+T1BOOL);
917 default:
918 if (r[2] == NIL)
919 return (NIL);
920 switch (r[0]) {
921 default:
922 panic("rval3");
923
924
925 /*
926 * An octal number
927 */
928 case T_BINT:
929 f = a8tol(r[2]);
930 goto conint;
931
932 /*
933 * A decimal number
934 */
935 case T_INT:
936 f = atof(r[2]);
937conint:
938 if (f > MAXINT || f < MININT) {
939 error("Constant too large for this implementation");
940 return (NIL);
941 }
942 l = f;
943 if (bytes(l, l) <= 2) {
944# ifdef OBJ
945 put(2, O_CON2, ( short ) l);
946# endif OBJ
947# ifdef PC
948 /*
949 * short constants are ints
950 */
951 putleaf( P2ICON , l , 0 , P2INT , 0 );
952# endif PC
953 return (nl+T2INT);
954 }
955# ifdef OBJ
956 put(2, O_CON4, l);
957# endif OBJ
958# ifdef PC
959 putleaf( P2ICON , l , 0 , P2INT , 0 );
960# endif PC
961 return (nl+T4INT);
962
963 /*
964 * A floating point number
965 */
966 case T_FINT:
967# ifdef OBJ
968 put(2, O_CON8, atof(r[2]));
969# endif OBJ
970# ifdef PC
971 putCON8( atof( r[2] ) );
972# endif PC
973 return (nl+TDOUBLE);
974
975 /*
976 * Constant strings. Note that constant characters
977 * are constant strings of length one; there is
978 * no constant string of length one.
979 */
980 case T_STRNG:
981 cp = r[2];
982 if (cp[1] == 0) {
983# ifdef OBJ
984 put(2, O_CONC, cp[0]);
985# endif OBJ
986# ifdef PC
987 putleaf( P2ICON , cp[0] , 0 , P2CHAR , 0 );
988# endif PC
989 return (nl+T1CHAR);
990 }
991 goto cstrng;
992 }
993
994 }
995}
996
997/*
998 * Can a class appear
999 * in a comparison ?
1000 */
1001nocomp(c)
1002 int c;
1003{
1004
1005 switch (c) {
1006 case TREC:
1007 if ( opt( 's' ) ) {
1008 standard();
1009 error("record comparison is non-standard");
1010 }
1011 break;
1012 case TFILE:
1013 case TARY:
1014 error("%ss may not participate in comparisons", clnames[c]);
1015 return (1);
1016 }
1017 return (NIL);
1018}
1019\f
1020 /*
1021 * this is sort of like gconst, except it works on expression trees
1022 * rather than declaration trees, and doesn't give error messages for
1023 * non-constant things.
1024 * as a side effect this fills in the con structure that gconst uses.
1025 * this returns TRUE or FALSE.
1026 */
1027constval(r)
1028 register int *r;
1029{
1030 register struct nl *np;
1031 register *cn;
1032 char *cp;
1033 int negd, sgnd;
1034 long ci;
1035
1036 con.ctype = NIL;
1037 cn = r;
1038 negd = sgnd = 0;
1039loop:
1040 /*
1041 * cn[2] is nil if error recovery generated a T_STRNG
1042 */
1043 if (cn == NIL || cn[2] == NIL)
1044 return FALSE;
1045 switch (cn[0]) {
1046 default:
1047 return FALSE;
1048 case T_MINUS:
1049 negd = 1 - negd;
1050 /* and fall through */
1051 case T_PLUS:
1052 sgnd++;
1053 cn = cn[2];
1054 goto loop;
1055 case T_NIL:
1056 con.cpval = NIL;
1057 con.cival = 0;
1058 con.crval = con.cival;
1059 con.ctype = nl + TNIL;
1060 break;
1061 case T_VAR:
1062 np = lookup(cn[2]);
1063 if (np == NIL || np->class != CONST) {
1064 return FALSE;
1065 }
1066 if ( cn[3] != NIL ) {
1067 return FALSE;
1068 }
1069 con.ctype = np->type;
1070 switch (classify(np->type)) {
1071 case TINT:
1072 con.crval = np->range[0];
1073 break;
1074 case TDOUBLE:
1075 con.crval = np->real;
1076 break;
1077 case TBOOL:
1078 case TCHAR:
1079 case TSCAL:
1080 con.cival = np->value[0];
1081 con.crval = con.cival;
1082 break;
1083 case TSTR:
1084 con.cpval = np->ptr[0];
1085 break;
1086 default:
1087 con.ctype = NIL;
1088 return FALSE;
1089 }
1090 break;
1091 case T_BINT:
1092 con.crval = a8tol(cn[2]);
1093 goto restcon;
1094 case T_INT:
1095 con.crval = atof(cn[2]);
1096 if (con.crval > MAXINT || con.crval < MININT) {
1097 derror("Constant too large for this implementation");
1098 con.crval = 0;
1099 }
1100restcon:
1101 ci = con.crval;
1102#ifndef PI0
1103 if (bytes(ci, ci) <= 2)
1104 con.ctype = nl+T2INT;
1105 else
1106#endif
1107 con.ctype = nl+T4INT;
1108 break;
1109 case T_FINT:
1110 con.ctype = nl+TDOUBLE;
1111 con.crval = atof(cn[2]);
1112 break;
1113 case T_STRNG:
1114 cp = cn[2];
1115 if (cp[1] == 0) {
1116 con.ctype = nl+T1CHAR;
1117 con.cival = cp[0];
1118 con.crval = con.cival;
1119 break;
1120 }
1121 con.ctype = nl+TSTR;
1122 con.cpval = cp;
1123 break;
1124 }
1125 if (sgnd) {
1126 if (isnta(con.ctype, "id")) {
1127 derror("%s constants cannot be signed", nameof(con.ctype));
1128 return FALSE;
1129 } else if (negd)
1130 con.crval = -con.crval;
1131 }
1132 return TRUE;
1133}
Continuous source code history from original PDP-7 UNIX to FreeBSD 2, the first fully unencumbered FreeBSD release.