![[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] / 43BSDReno / pgrm / pascal / src|
Return to rval.c CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / 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.2 (Berkeley) 4/7/87";
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: # ifdef tahoe
653: /* prepare for ediv workaround, see below. */
654: if (r->tag == T_MOD) {
655: (void) rvalue(r->expr_node.lhs, NLNIL, RREQ);
656: sconv(p2type(p), PCCT_INT);
657: }
658: # endif tahoe
659: # endif PC
660: p1 = rvalue(r->expr_node.rhs, NLNIL , RREQ );
661: # ifdef PC
662: sconv(p2type(p1), PCCT_INT);
663: # endif PC
664: if (p == NLNIL || p1 == NLNIL)
665: return (NLNIL);
666: if (isnta(p, "i")) {
667: error("Left operand of %s must be integer, not %s", opname, nameof(p));
668: return (NLNIL);
669: }
670: if (isnta(p1, "i")) {
671: error("Right operand of %s must be integer, not %s", opname, nameof(p1));
672: return (NLNIL);
673: }
674: # ifdef OBJ
675: return (gen(NIL, r->tag, width(p), width(p1)));
676: # endif OBJ
677: # ifdef PC
678: # ifndef tahoe
679: putop( r->tag == T_DIV ? PCC_DIV : PCC_MOD , PCCT_INT );
680: return ( nl + T4INT );
681: # else tahoe
682: putop( PCC_DIV , PCCT_INT );
683: if (r->tag == T_MOD) {
684: /*
685: * avoid f1 bug: PCC_MOD would generate an 'ediv',
686: * which would reuire too many registers to evaluate
687: * things like
688: * var i:boolean;j:integer; i := (j+1) = (j mod 2);
689: * so, instead of
690: * PCC_MOD
691: * / \
692: * p p1
693: * we put
694: * PCC_MINUS
695: * / \
696: * p PCC_MUL
697: * / \
698: * PCC_DIV p1
699: * / \
700: * p p1
701: *
702: * we already have put p, p, p1, PCC_DIV. and now...
703: */
704: rvalue(r->expr_node.rhs, NLNIL , RREQ );
705: sconv(p2type(p1), PCCT_INT);
706: putop( PCC_MUL, PCCT_INT );
707: putop( PCC_MINUS, PCCT_INT );
708: }
709: return ( nl + T4INT );
710: # endif tahoe
711: # endif PC
712:
713: case T_EQ:
714: case T_NE:
715: case T_LT:
716: case T_GT:
717: case T_LE:
718: case T_GE:
719: /*
720: * Since there can be no, a priori, knowledge
721: * of the context type should a constant string
722: * or set arise, we must poke around to find such
723: * a type if possible. Since constant strings can
724: * always masquerade as identifiers, this is always
725: * necessary.
726: * see the note in the obj section of case T_MULT above
727: * for the determination of the base type of empty sets.
728: */
729: codeoff();
730: p1 = rvalue(r->expr_node.rhs, NLNIL , RREQ );
731: codeon();
732: if (p1 == NLNIL)
733: return (NLNIL);
734: contype = p1;
735: # ifdef OBJ
736: if (p1->class == STR) {
737: /*
738: * For constant strings we want
739: * the longest type so as to be
740: * able to do padding (more importantly
741: * avoiding truncation). For clarity,
742: * we get this length here.
743: */
744: codeoff();
745: p = rvalue(r->expr_node.lhs, NLNIL , RREQ );
746: codeon();
747: if (p == NLNIL)
748: return (NLNIL);
749: if (width(p) > width(p1))
750: contype = p;
751: }
752: if (isa(p1, "t")) {
753: codeoff();
754: contype = rvalue(r->expr_node.lhs, p1, RREQ);
755: codeon();
756: if (contype == NLNIL) {
757: return NLNIL;
758: }
759: }
760: /*
761: * Now we generate code for
762: * the operands of the relational
763: * operation.
764: */
765: p = rvalue(r->expr_node.lhs, contype , RREQ );
766: if (p == NLNIL)
767: return (NLNIL);
768: p1 = rvalue(r->expr_node.rhs, p , RREQ );
769: if (p1 == NLNIL)
770: return (NLNIL);
771: # endif OBJ
772: # ifdef PC
773: c1 = classify( p1 );
774: if ( c1 == TSET || c1 == TSTR || c1 == TREC ) {
775: putleaf( PCC_ICON , 0 , 0
776: , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
777: , c1 == TSET ? relts[ r->tag - T_EQ ]
778: : relss[ r->tag - T_EQ ] );
779: /*
780: * for [] and strings, comparisons are done on
781: * the maximum width of the two sides.
782: * for other sets, we have to ask the left side
783: * what type it is based on the type of the right.
784: * (this matters for intsets).
785: */
786: if ( c1 == TSTR ) {
787: codeoff();
788: p = rvalue( r->expr_node.lhs , NLNIL , LREQ );
789: codeon();
790: if ( p == NLNIL ) {
791: return NLNIL;
792: }
793: if ( lwidth( p ) > lwidth( p1 ) ) {
794: contype = p;
795: }
796: } else if ( c1 == TSET ) {
797: codeoff();
798: contype = rvalue(r->expr_node.lhs, p1, LREQ);
799: codeon();
800: if (contype == NLNIL) {
801: return NLNIL;
802: }
803: }
804: /*
805: * put out the width of the comparison.
806: */
807: putleaf(PCC_ICON, (int) lwidth(contype), 0, PCCT_INT, (char *) 0);
808: /*
809: * and the left hand side,
810: * for sets, strings, records
811: */
812: p = rvalue( r->expr_node.lhs , contype , LREQ );
813: if ( p == NLNIL ) {
814: return NLNIL;
815: }
816: putop( PCC_CM , PCCT_INT );
817: p1 = rvalue( r->expr_node.rhs , p , LREQ );
818: if ( p1 == NLNIL ) {
819: return NLNIL;
820: }
821: putop( PCC_CM , PCCT_INT );
822: putop( PCC_CALL , PCCT_INT );
823: } else {
824: /*
825: * the easy (scalar or error) case
826: */
827: p = rvalue( r->expr_node.lhs , contype , RREQ );
828: if ( p == NLNIL ) {
829: return NLNIL;
830: }
831: /*
832: * since the second pass can't do
833: * long op double or double op long
834: * we may have to do some coercing.
835: */
836: tuac(p, p1, &rettype, (int *) (&ctype));
837: p1 = rvalue( r->expr_node.rhs , p , RREQ );
838: if ( p1 == NLNIL ) {
839: return NLNIL;
840: }
841: tuac(p1, p, &rettype, (int *) (&ctype));
842: putop((int) relops[ r->tag - T_EQ ] , PCCT_INT );
843: sconv(PCCT_INT, PCCT_CHAR);
844: }
845: # endif PC
846: c = classify(p);
847: c1 = classify(p1);
848: if (nocomp(c) || nocomp(c1))
849: return (NLNIL);
850: # ifdef OBJ
851: g = NIL;
852: # endif
853: switch (c) {
854: case TBOOL:
855: case TCHAR:
856: if (c != c1)
857: goto clash;
858: break;
859: case TINT:
860: case TDOUBLE:
861: if (c1 != TINT && c1 != TDOUBLE)
862: goto clash;
863: break;
864: case TSCAL:
865: if (c1 != TSCAL)
866: goto clash;
867: if (scalar(p) != scalar(p1))
868: goto nonident;
869: break;
870: case TSET:
871: if (c1 != TSET)
872: goto clash;
873: if ( opt( 's' ) &&
874: ( ( r->tag == T_LT) || (r->tag == T_GT) ) &&
875: ( line != nssetline ) ) {
876: nssetline = line;
877: standard();
878: error("%s comparison on sets is non-standard" , opname );
879: }
880: if (p != p1)
881: goto nonident;
882: # ifdef OBJ
883: g = TSET;
884: # endif
885: break;
886: case TREC:
887: if ( c1 != TREC ) {
888: goto clash;
889: }
890: if ( p != p1 ) {
891: goto nonident;
892: }
893: if (r->tag != T_EQ && r->tag != T_NE) {
894: error("%s not allowed on records - only allow = and <>" , opname );
895: return (NLNIL);
896: }
897: # ifdef OBJ
898: g = TREC;
899: # endif
900: break;
901: case TPTR:
902: case TNIL:
903: if (c1 != TPTR && c1 != TNIL)
904: goto clash;
905: if (r->tag != T_EQ && r->tag != T_NE) {
906: error("%s not allowed on pointers - only allow = and <>" , opname );
907: return (NLNIL);
908: }
909: if (p != nl+TNIL && p1 != nl+TNIL && p != p1)
910: goto nonident;
911: break;
912: case TSTR:
913: if (c1 != TSTR)
914: goto clash;
915: if (width(p) != width(p1)) {
916: error("Strings not same length in %s comparison", opname);
917: return (NLNIL);
918: }
919: # ifdef OBJ
920: g = TSTR;
921: # endif OBJ
922: break;
923: default:
924: panic("rval2");
925: }
926: # ifdef OBJ
927: return (gen(g, r->tag, width(p), width(p1)));
928: # endif OBJ
929: # ifdef PC
930: return nl + TBOOL;
931: # endif PC
932: clash:
933: error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname);
934: return (NLNIL);
935: nonident:
936: error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname);
937: return (NLNIL);
938:
939: case T_IN:
940: rt = r->expr_node.rhs;
941: # ifdef OBJ
942: if (rt != TR_NIL && rt->tag == T_CSET) {
943: (void) precset( rt , NLNIL , &csetd );
944: p1 = csetd.csettype;
945: if (p1 == NLNIL)
946: return NLNIL;
947: postcset( rt, &csetd);
948: } else {
949: p1 = stkrval(r->expr_node.rhs, NLNIL , (long) RREQ );
950: rt = TR_NIL;
951: }
952: # endif OBJ
953: # ifdef PC
954: if (rt != TR_NIL && rt->tag == T_CSET) {
955: if ( precset( rt , NLNIL , &csetd ) ) {
956: putleaf( PCC_ICON , 0 , 0
957: , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
958: , "_IN" );
959: } else {
960: putleaf( PCC_ICON , 0 , 0
961: , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
962: , "_INCT" );
963: }
964: p1 = csetd.csettype;
965: if (p1 == NIL)
966: return NLNIL;
967: } else {
968: putleaf( PCC_ICON , 0 , 0
969: , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
970: , "_IN" );
971: codeoff();
972: p1 = rvalue(r->expr_node.rhs, NLNIL , LREQ );
973: codeon();
974: }
975: # endif PC
976: p = stkrval(r->expr_node.lhs, NLNIL , (long) RREQ );
977: if (p == NIL || p1 == NIL)
978: return (NLNIL);
979: if (p1->class != (char) SET) {
980: error("Right operand of 'in' must be a set, not %s", nameof(p1));
981: return (NLNIL);
982: }
983: if (incompat(p, p1->type, r->expr_node.lhs)) {
984: cerror("Index type clashed with set component type for 'in'");
985: return (NLNIL);
986: }
987: setran(p1->type);
988: # ifdef OBJ
989: if (rt == TR_NIL || csetd.comptime)
990: (void) put(4, O_IN, width(p1), set.lwrb, set.uprbp);
991: else
992: (void) put(2, O_INCT,
993: (int)(3 + csetd.singcnt + 2*csetd.paircnt));
994: # endif OBJ
995: # ifdef PC
996: if ( rt == TR_NIL || rt->tag != T_CSET ) {
997: putleaf( PCC_ICON , set.lwrb , 0 , PCCT_INT , (char *) 0 );
998: putop( PCC_CM , PCCT_INT );
999: putleaf( PCC_ICON , set.uprbp , 0 , PCCT_INT , (char *) 0 );
1000: putop( PCC_CM , PCCT_INT );
1001: p1 = rvalue( r->expr_node.rhs , NLNIL , LREQ );
1002: if ( p1 == NLNIL ) {
1003: return NLNIL;
1004: }
1005: putop( PCC_CM , PCCT_INT );
1006: } else if ( csetd.comptime ) {
1007: putleaf( PCC_ICON , set.lwrb , 0 , PCCT_INT , (char *) 0 );
1008: putop( PCC_CM , PCCT_INT );
1009: putleaf( PCC_ICON , set.uprbp , 0 , PCCT_INT , (char *) 0 );
1010: putop( PCC_CM , PCCT_INT );
1011: postcset( r->expr_node.rhs , &csetd );
1012: putop( PCC_CM , PCCT_INT );
1013: } else {
1014: postcset( r->expr_node.rhs , &csetd );
1015: }
1016: putop( PCC_CALL , PCCT_INT );
1017: sconv(PCCT_INT, PCCT_CHAR);
1018: # endif PC
1019: return (nl+T1BOOL);
1020: default:
1021: if (r->expr_node.lhs == TR_NIL)
1022: return (NLNIL);
1023: switch (r->tag) {
1024: default:
1025: panic("rval3");
1026:
1027:
1028: /*
1029: * An octal number
1030: */
1031: case T_BINT:
1032: f.pdouble = a8tol(r->const_node.cptr);
1033: goto conint;
1034:
1035: /*
1036: * A decimal number
1037: */
1038: case T_INT:
1039: f.pdouble = atof(r->const_node.cptr);
1040: conint:
1041: if (f.pdouble > MAXINT || f.pdouble < MININT) {
1042: error("Constant too large for this implementation");
1043: return (NLNIL);
1044: }
1045: l = f.pdouble;
1046: # ifdef OBJ
1047: if (bytes(l, l) <= 2) {
1048: (void) put(2, O_CON2, ( short ) l);
1049: return (nl+T2INT);
1050: }
1051: (void) put(2, O_CON4, l);
1052: return (nl+T4INT);
1053: # endif OBJ
1054: # ifdef PC
1055: switch (bytes(l, l)) {
1056: case 1:
1057: putleaf(PCC_ICON, (int) l, 0, PCCT_CHAR,
1058: (char *) 0);
1059: return nl+T1INT;
1060: case 2:
1061: putleaf(PCC_ICON, (int) l, 0, PCCT_SHORT,
1062: (char *) 0);
1063: return nl+T2INT;
1064: case 4:
1065: putleaf(PCC_ICON, (int) l, 0, PCCT_INT,
1066: (char *) 0);
1067: return nl+T4INT;
1068: }
1069: # endif PC
1070:
1071: /*
1072: * A floating point number
1073: */
1074: case T_FINT:
1075: # ifdef OBJ
1076: (void) put(2, O_CON8, atof(r->const_node.cptr));
1077: # endif OBJ
1078: # ifdef PC
1079: putCON8( atof( r->const_node.cptr ) );
1080: # endif PC
1081: return (nl+TDOUBLE);
1082:
1083: /*
1084: * Constant strings. Note that constant characters
1085: * are constant strings of length one; there is
1086: * no constant string of length one.
1087: */
1088: case T_STRNG:
1089: cp = r->const_node.cptr;
1090: if (cp[1] == 0) {
1091: # ifdef OBJ
1092: (void) put(2, O_CONC, cp[0]);
1093: # endif OBJ
1094: # ifdef PC
1095: putleaf( PCC_ICON , cp[0] , 0 , PCCT_CHAR ,
1096: (char *) 0 );
1097: # endif PC
1098: return (nl+T1CHAR);
1099: }
1100: goto cstrng;
1101: }
1102:
1103: }
1104: }
1105:
1106: /*
1107: * Can a class appear
1108: * in a comparison ?
1109: */
1110: nocomp(c)
1111: int c;
1112: {
1113:
1114: switch (c) {
1115: case TREC:
1116: if ( line != reccompline ) {
1117: reccompline = line;
1118: warning();
1119: if ( opt( 's' ) ) {
1120: standard();
1121: }
1122: error("record comparison is non-standard");
1123: }
1124: break;
1125: case TFILE:
1126: case TARY:
1127: error("%ss may not participate in comparisons", clnames[c]);
1128: return (1);
1129: }
1130: return (NIL);
1131: }
1132:
1133: /*
1134: * this is sort of like gconst, except it works on expression trees
1135: * rather than declaration trees, and doesn't give error messages for
1136: * non-constant things.
1137: * as a side effect this fills in the con structure that gconst uses.
1138: * this returns TRUE or FALSE.
1139: */
1140:
1141: bool
1142: constval(r)
1143: register struct tnode *r;
1144: {
1145: register struct nl *np;
1146: register struct tnode *cn;
1147: char *cp;
1148: int negd, sgnd;
1149: long ci;
1150:
1151: con.ctype = NIL;
1152: cn = r;
1153: negd = sgnd = 0;
1154: loop:
1155: /*
1156: * cn[2] is nil if error recovery generated a T_STRNG
1157: */
1158: if (cn == TR_NIL || cn->expr_node.lhs == TR_NIL)
1159: return FALSE;
1160: switch (cn->tag) {
1161: default:
1162: return FALSE;
1163: case T_MINUS:
1164: negd = 1 - negd;
1165: /* and fall through */
1166: case T_PLUS:
1167: sgnd++;
1168: cn = cn->un_expr.expr;
1169: goto loop;
1170: case T_NIL:
1171: con.cpval = NIL;
1172: con.cival = 0;
1173: con.crval = con.cival;
1174: con.ctype = nl + TNIL;
1175: break;
1176: case T_VAR:
1177: np = lookup(cn->var_node.cptr);
1178: if (np == NLNIL || np->class != CONST) {
1179: return FALSE;
1180: }
1181: if ( cn->var_node.qual != TR_NIL ) {
1182: return FALSE;
1183: }
1184: con.ctype = np->type;
1185: switch (classify(np->type)) {
1186: case TINT:
1187: con.crval = np->range[0];
1188: break;
1189: case TDOUBLE:
1190: con.crval = np->real;
1191: break;
1192: case TBOOL:
1193: case TCHAR:
1194: case TSCAL:
1195: con.cival = np->value[0];
1196: con.crval = con.cival;
1197: break;
1198: case TSTR:
1199: con.cpval = (char *) np->ptr[0];
1200: break;
1201: default:
1202: con.ctype = NIL;
1203: return FALSE;
1204: }
1205: break;
1206: case T_BINT:
1207: con.crval = a8tol(cn->const_node.cptr);
1208: goto restcon;
1209: case T_INT:
1210: con.crval = atof(cn->const_node.cptr);
1211: if (con.crval > MAXINT || con.crval < MININT) {
1212: derror("Constant too large for this implementation");
1213: con.crval = 0;
1214: }
1215: restcon:
1216: ci = con.crval;
1217: #ifndef PI0
1218: if (bytes(ci, ci) <= 2)
1219: con.ctype = nl+T2INT;
1220: else
1221: #endif
1222: con.ctype = nl+T4INT;
1223: break;
1224: case T_FINT:
1225: con.ctype = nl+TDOUBLE;
1226: con.crval = atof(cn->const_node.cptr);
1227: break;
1228: case T_STRNG:
1229: cp = cn->const_node.cptr;
1230: if (cp[1] == 0) {
1231: con.ctype = nl+T1CHAR;
1232: con.cival = cp[0];
1233: con.crval = con.cival;
1234: break;
1235: }
1236: con.ctype = nl+TSTR;
1237: con.cpval = cp;
1238: break;
1239: }
1240: if (sgnd) {
1241: if (isnta(con.ctype, "id")) {
1242: derror("%s constants cannot be signed", nameof(con.ctype));
1243: return FALSE;
1244: } else if (negd)
1245: con.crval = -con.crval;
1246: }
1247: return TRUE;
1248: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.