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