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