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