From 55839dac5492f57286d5aa7a561b82a3aae66f7d Mon Sep 17 00:00:00 2001 From: "Peter B. Kessler" Date: Thu, 28 Aug 1980 02:56:18 -0800 Subject: [PATCH] date and time created 80/08/27 19:56:18 by peter SCCS-vsn: usr.bin/pascal/src/rval.c 1.1 --- usr/src/usr.bin/pascal/src/rval.c | 1133 +++++++++++++++++++++++++++++ 1 file changed, 1133 insertions(+) create mode 100644 usr/src/usr.bin/pascal/src/rval.c diff --git a/usr/src/usr.bin/pascal/src/rval.c b/usr/src/usr.bin/pascal/src/rval.c new file mode 100644 index 0000000000..8c46f6c80d --- /dev/null +++ b/usr/src/usr.bin/pascal/src/rval.c @@ -0,0 +1,1133 @@ +/* Copyright (c) 1979 Regents of the University of California */ + +static char sccsid[] = "@(#)rval.c 1.1 %G%"; + +#include "whoami.h" +#include "0.h" +#include "tree.h" +#include "opcode.h" +#include "objfmt.h" +#ifdef PC +# include "pc.h" +# include "pcops.h" +#endif PC + +extern char *opnames[]; +bool inempty = FALSE; + +#ifdef PC + char *relts[] = { + "_RELEQ" , "_RELNE" , + "_RELTLT" , "_RELTGT" , + "_RELTLE" , "_RELTGE" + }; + char *relss[] = { + "_RELEQ" , "_RELNE" , + "_RELSLT" , "_RELSGT" , + "_RELSLE" , "_RELSGE" + }; + long relops[] = { + P2EQ , P2NE , + P2LT , P2GT , + P2LE , P2GE + }; + long mathop[] = { P2MUL , P2PLUS , P2MINUS }; + char *setop[] = { "_MULT" , "_ADDT" , "_SUBT" }; +#endif PC +/* + * Rvalue - an expression. + * + * Contype is the type that the caller would prefer, nand is important + * if constant sets or constant strings are involved, the latter + * because of string padding. + * required is a flag whether an lvalue or an rvalue is required. + * only VARs and structured things can have gt their lvalue this way. + */ +struct nl * +rvalue(r, contype , required ) + int *r; + struct nl *contype; + int required; +{ + register struct nl *p, *p1; + register struct nl *q; + int c, c1, *rt, w, g; + char *cp, *cp1, *opname; + long l; + double f; + extern int flagwas; + struct csetstr csetd; +# ifdef PC + struct nl *rettype; + long ctype; + long tempoff; +# endif PC + + if (r == NIL) + return (NIL); + if (nowexp(r)) + return (NIL); + /* + * Pick up the name of the operation + * for future error messages. + */ + if (r[0] <= T_IN) + opname = opnames[r[0]]; + + /* + * The root of the tree tells us what sort of expression we have. + */ + switch (r[0]) { + + /* + * The constant nil + */ + case T_NIL: +# ifdef OBJ + put(2, O_CON2, 0); +# endif OBJ +# ifdef PC + putleaf( P2ICON , 0 , 0 , P2PTR|P2UNDEFINED , 0 ); +# endif PC + return (nl+TNIL); + + /* + * Function call with arguments. + */ + case T_FCALL: +# ifdef OBJ + return (funccod(r)); +# endif OBJ +# ifdef PC + return (pcfunccod( r )); +# endif PC + + case T_VAR: + p = lookup(r[2]); + if (p == NIL || p->class == BADUSE) + return (NIL); + switch (p->class) { + case VAR: + /* + * If a variable is + * qualified then get + * the rvalue by a + * lvalue and an ind. + */ + if (r[3] != NIL) + goto ind; + q = p->type; + if (q == NIL) + return (NIL); +# ifdef OBJ + w = width(q); + switch (w) { + case 8: + put(2, O_RV8 | bn << 8+INDX, p->value[0]); + break; + case 4: + put(2, O_RV4 | bn << 8+INDX, p->value[0]); + break; + case 2: + put(2, O_RV2 | bn << 8+INDX, p->value[0]); + break; + case 1: + put(2, O_RV1 | bn << 8+INDX, p->value[0]); + break; + default: + put(3, O_RV | bn << 8+INDX, p->value[0], w); + } +# endif OBJ +# ifdef PC + if ( required == RREQ ) { + putRV( p -> symbol , bn , p -> value[0] + , p2type( q ) ); + } else { + putLV( p -> symbol , bn , p -> value[0] + , p2type( q ) ); + } +# endif PC + return (q); + + case WITHPTR: + case REF: + /* + * A lvalue for these + * is actually what one + * might consider a rvalue. + */ +ind: + q = lvalue(r, NOFLAGS , LREQ ); + if (q == NIL) + return (NIL); +# ifdef OBJ + w = width(q); + switch (w) { + case 8: + put(1, O_IND8); + break; + case 4: + put(1, O_IND4); + break; + case 2: + put(1, O_IND2); + break; + case 1: + put(1, O_IND1); + break; + default: + put(2, O_IND, w); + } +# endif OBJ +# ifdef PC + if ( required == RREQ ) { + putop( P2UNARY P2MUL , p2type( q ) ); + } +# endif PC + return (q); + + case CONST: + if (r[3] != NIL) { + error("%s is a constant and cannot be qualified", r[2]); + return (NIL); + } + q = p->type; + if (q == NIL) + return (NIL); + if (q == nl+TSTR) { + /* + * Find the size of the string + * constant if needed. + */ + cp = p->ptr[0]; +cstrng: + cp1 = cp; + for (c = 0; *cp++; c++) + continue; + if (contype != NIL && !opt('s')) { + if (width(contype) < c && classify(contype) == TSTR) { + error("Constant string too long"); + return (NIL); + } + c = width(contype); + } +# ifdef OBJ + put( 2 + (sizeof(char *)/sizeof(short)) + , O_CONG, c, cp1); +# endif OBJ +# ifdef PC + putCONG( cp1 , c , required ); +# endif PC + /* + * Define the string temporarily + * so later people can know its + * width. + * cleaned out by stat. + */ + q = defnl(0, STR, 0, c); + q->type = q; + return (q); + } + if (q == nl+T1CHAR) { +# ifdef OBJ + put(2, O_CONC, p->value[0]); +# endif OBJ +# ifdef PC + putleaf( P2ICON , p -> value[0] , 0 + , P2CHAR , 0 ); +# endif PC + return (q); + } + /* + * Every other kind of constant here + */ + switch (width(q)) { + case 8: +#ifndef DEBUG +# ifdef OBJ + put(2, O_CON8, p->real); +# endif OBJ +# ifdef PC + putCON8( p -> real ); +# endif PC +#else + if (hp21mx) { + f = p->real; + conv(&f); + l = f.plong; + put(2, O_CON4, l); + } else +# ifdef OBJ + put(2, O_CON8, p->real); +# endif OBJ +# ifdef PC + putCON8( p -> real ); +# endif PC +#endif + break; + case 4: +# ifdef OBJ + put(2, O_CON4, p->range[0]); +# endif OBJ +# ifdef PC + putleaf( P2ICON , p -> range[0] , 0 + , P2INT , 0 ); +# endif PC + break; + case 2: +# ifdef OBJ + put(2, O_CON2, ( short ) p->range[0]); +# endif OBJ +# ifdef PC + /* + * make short constants ints + */ + putleaf( P2ICON , (short) p -> range[0] + , 0 , P2INT , 0 ); +# endif PC + break; + case 1: +# ifdef OBJ + put(2, O_CON1, p->value[0]); +# endif OBJ +# ifdef PC + /* + * make char constants ints + */ + putleaf( P2ICON , p -> value[0] , 0 + , P2INT , 0 ); +# endif PC + break; + default: + panic("rval"); + } + return (q); + + case FUNC: + /* + * Function call with no arguments. + */ + if (r[3]) { + error("Can't qualify a function result value"); + return (NIL); + } +# ifdef OBJ + return (funccod((int *) r)); +# endif OBJ +# ifdef PC + return (pcfunccod( r )); +# endif PC + + case TYPE: + error("Type names (e.g. %s) allowed only in declarations", p->symbol); + return (NIL); + + case PROC: + error("Procedure %s found where expression required", p->symbol); + return (NIL); + default: + panic("rvid"); + } + /* + * Constant sets + */ + case T_CSET: +# ifdef OBJ + if ( precset( r , contype , &csetd ) ) { + if ( csetd.csettype == NIL ) { + return NIL; + } + postcset( r , &csetd ); + } else { + put( 2, O_PUSH, -width(csetd.csettype)); + postcset( r , &csetd ); + setran( ( csetd.csettype ) -> type ); + put( 2, O_CON24, set.uprbp); + put( 2, O_CON24, set.lwrb); + put( 2, O_CTTOT, 5 + csetd.singcnt + 2 * csetd.paircnt); + } + return csetd.csettype; +# endif OBJ +# ifdef PC + if ( precset( r , contype , &csetd ) ) { + if ( csetd.csettype == NIL ) { + return NIL; + } + postcset( r , &csetd ); + } else { + putleaf( P2ICON , 0 , 0 + , ADDTYPE( P2FTN | P2INT , P2PTR ) + , "_CTTOT" ); + /* + * allocate a temporary and use it + */ + sizes[ cbn ].om_off -= lwidth( csetd.csettype ); + tempoff = sizes[ cbn ].om_off; + putlbracket( ftnno , -tempoff ); + if ( tempoff < sizes[ cbn ].om_max ) { + sizes[ cbn ].om_max = tempoff; + } + putLV( 0 , cbn , tempoff , P2PTR|P2STRTY ); + setran( ( csetd.csettype ) -> type ); + putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 ); + putop( P2LISTOP , P2INT ); + putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 ); + putop( P2LISTOP , P2INT ); + postcset( r , &csetd ); + putop( P2CALL , P2INT ); + } + return csetd.csettype; +# endif PC + + /* + * Unary plus and minus + */ + case T_PLUS: + case T_MINUS: + q = rvalue(r[2], NIL , RREQ ); + if (q == NIL) + return (NIL); + if (isnta(q, "id")) { + error("Operand of %s must be integer or real, not %s", opname, nameof(q)); + return (NIL); + } + if (r[0] == T_MINUS) { +# ifdef OBJ + put(1, O_NEG2 + (width(q) >> 2)); +# endif OBJ +# ifdef PC + putop( P2UNARY P2MINUS , p2type( q ) ); +# endif PC + return (isa(q, "d") ? q : nl+T4INT); + } + return (q); + + case T_NOT: + q = rvalue(r[2], NIL , RREQ ); + if (q == NIL) + return (NIL); + if (isnta(q, "b")) { + error("not must operate on a Boolean, not %s", nameof(q)); + return (NIL); + } +# ifdef OBJ + put(1, O_NOT); +# endif OBJ +# ifdef PC + putop( P2NOT , P2INT ); +# endif PC + return (nl+T1BOOL); + + case T_AND: + case T_OR: + p = rvalue(r[2], NIL , RREQ ); + p1 = rvalue(r[3], NIL , RREQ ); + if (p == NIL || p1 == NIL) + return (NIL); + if (isnta(p, "b")) { + error("Left operand of %s must be Boolean, not %s", opname, nameof(p)); + return (NIL); + } + if (isnta(p1, "b")) { + error("Right operand of %s must be Boolean, not %s", opname, nameof(p1)); + return (NIL); + } +# ifdef OBJ + put(1, r[0] == T_AND ? O_AND : O_OR); +# endif OBJ +# ifdef PC + /* + * note the use of & and | rather than && and || + * to force evaluation of all the expressions. + */ + putop( r[ 0 ] == T_AND ? P2AND : P2OR , P2INT ); +# endif PC + return (nl+T1BOOL); + + case T_DIVD: +# ifdef OBJ + p = rvalue(r[2], NIL , RREQ ); + p1 = rvalue(r[3], NIL , RREQ ); +# endif OBJ +# ifdef PC + /* + * force these to be doubles for the divide + */ + p = rvalue( r[ 2 ] , NIL , RREQ ); + if ( isnta( p , "d" ) ) { + putop( P2SCONV , P2DOUBLE ); + } + p1 = rvalue( r[ 3 ] , NIL , RREQ ); + if ( isnta( p1 , "d" ) ) { + putop( P2SCONV , P2DOUBLE ); + } +# endif PC + if (p == NIL || p1 == NIL) + return (NIL); + if (isnta(p, "id")) { + error("Left operand of / must be integer or real, not %s", nameof(p)); + return (NIL); + } + if (isnta(p1, "id")) { + error("Right operand of / must be integer or real, not %s", nameof(p1)); + return (NIL); + } +# ifdef OBJ + return gen(NIL, r[0], width(p), width(p1)); +# endif OBJ +# ifdef PC + putop( P2DIV , P2DOUBLE ); + return nl + TDOUBLE; +# endif PC + + case T_MULT: + case T_ADD: + case T_SUB: +# ifdef OBJ + /* + * If the context hasn't told us + * the type and a constant set is + * present on the left we need to infer + * the type from the right if possible + * before generating left side code. + */ + if (contype == NIL && (rt = r[2]) != NIL && rt[1] == SAWCON) { + codeoff(); + contype = rvalue(r[3], NIL , RREQ ); + codeon(); + if (contype == NIL) + return (NIL); + } + p = rvalue(r[2], contype , RREQ ); + p1 = rvalue(r[3], p , RREQ ); + if (p == NIL || p1 == NIL) + return (NIL); + if (isa(p, "id") && isa(p1, "id")) + return (gen(NIL, r[0], width(p), width(p1))); + if (isa(p, "t") && isa(p1, "t")) { + if (p != p1) { + error("Set types of operands of %s must be identical", opname); + return (NIL); + } + gen(TSET, r[0], width(p), 0); + return (p); + } +# endif OBJ +# ifdef PC + /* + * the second pass can't do + * long op double or double op long + * so we have to know the type of both operands + * also, it gets tricky for sets, which are done + * by function calls. + */ + codeoff(); + p1 = rvalue( r[ 3 ] , contype , RREQ ); + codeon(); + if ( isa( p1 , "id" ) ) { + p = rvalue( r[ 2 ] , contype , RREQ ); + if ( ( p == NIL ) || ( p1 == NIL ) ) { + return NIL; + } + if ( isa( p , "i" ) && isa( p1 , "d" ) ) { + putop( P2SCONV , P2DOUBLE ); + } + p1 = rvalue( r[ 3 ] , contype , RREQ ); + if ( isa( p , "d" ) && isa( p1 , "i" ) ) { + putop( P2SCONV , P2DOUBLE ); + } + if ( isa( p , "id" ) ) { + if ( isa( p , "d" ) || isa( p1 , "d" ) ) { + ctype = P2DOUBLE; + rettype = nl + TDOUBLE; + } else { + ctype = P2INT; + rettype = nl + T4INT; + } + putop( mathop[ r[0] - T_MULT ] , ctype ); + return rettype; + } + } + if ( isa( p1 , "t" ) ) { + putleaf( P2ICON , 0 , 0 + , ADDTYPE( ADDTYPE( P2PTR | P2STRTY , P2FTN ) + , P2PTR ) + , setop[ r[0] - T_MULT ] ); + /* + * allocate a temporary and use it + */ + sizes[ cbn ].om_off -= lwidth( p1 ); + tempoff = sizes[ cbn ].om_off; + putlbracket( ftnno , -tempoff ); + if ( tempoff < sizes[ cbn ].om_max ) { + sizes[ cbn ].om_max = tempoff; + } + putLV( 0 , cbn , tempoff , P2PTR|P2STRTY ); + p = rvalue( r[2] , p1 , LREQ ); + if ( isa( p , "t" ) ) { + putop( P2LISTOP , P2INT ); + if ( p == NIL || p1 == NIL ) { + return NIL; + } + p1 = rvalue( r[3] , p , LREQ ); + if ( p != p1 ) { + error("Set types of operands of %s must be identical", opname); + return NIL; + } + putop( P2LISTOP , P2INT ); + putleaf( P2ICON , lwidth( p1 ) / sizeof( long ) , 0 + , P2INT , 0 ); + putop( P2LISTOP , P2INT ); + putop( P2CALL , P2PTR | P2STRTY ); + return p; + } + } + if ( isnta( p1 , "idt" ) ) { + /* + * find type of left operand for error message. + */ + p = rvalue( r[2] , contype , RREQ ); + } + /* + * don't give spurious error messages. + */ + if ( p == NIL || p1 == NIL ) { + return NIL; + } +# endif PC + if (isnta(p, "idt")) { + error("Left operand of %s must be integer, real or set, not %s", opname, nameof(p)); + return (NIL); + } + if (isnta(p1, "idt")) { + error("Right operand of %s must be integer, real or set, not %s", opname, nameof(p1)); + return (NIL); + } + error("Cannot mix sets with integers and reals as operands of %s", opname); + return (NIL); + + case T_MOD: + case T_DIV: + p = rvalue(r[2], NIL , RREQ ); + p1 = rvalue(r[3], NIL , RREQ ); + if (p == NIL || p1 == NIL) + return (NIL); + if (isnta(p, "i")) { + error("Left operand of %s must be integer, not %s", opname, nameof(p)); + return (NIL); + } + if (isnta(p1, "i")) { + error("Right operand of %s must be integer, not %s", opname, nameof(p1)); + return (NIL); + } +# ifdef OBJ + return (gen(NIL, r[0], width(p), width(p1))); +# endif OBJ +# ifdef PC + putop( r[ 0 ] == T_DIV ? P2DIV : P2MOD , P2INT ); + return ( nl + T4INT ); +# endif PC + + case T_EQ: + case T_NE: + case T_LT: + case T_GT: + case T_LE: + case T_GE: + /* + * Since there can be no, a priori, knowledge + * of the context type should a constant string + * or set arise, we must poke around to find such + * a type if possible. Since constant strings can + * always masquerade as identifiers, this is always + * necessary. + */ + codeoff(); + p1 = rvalue(r[3], NIL , RREQ ); + codeon(); + if (p1 == NIL) + return (NIL); + contype = p1; +# ifdef OBJ + if (p1 == nl+TSET || p1->class == STR) { + /* + * For constant strings we want + * the longest type so as to be + * able to do padding (more importantly + * avoiding truncation). For clarity, + * we get this length here. + */ + codeoff(); + p = rvalue(r[2], NIL , RREQ ); + codeon(); + if (p == NIL) + return (NIL); + if (p1 == nl+TSET || width(p) > width(p1)) + contype = p; + } + /* + * Now we generate code for + * the operands of the relational + * operation. + */ + p = rvalue(r[2], contype , RREQ ); + if (p == NIL) + return (NIL); + p1 = rvalue(r[3], p , RREQ ); + if (p1 == NIL) + return (NIL); +# endif OBJ +# ifdef PC + c1 = classify( p1 ); + if ( c1 == TSET || c1 == TSTR || c1 == TREC ) { + putleaf( P2ICON , 0 , 0 + , ADDTYPE( P2FTN | P2INT , P2PTR ) + , c1 == TSET ? relts[ r[0] - T_EQ ] + : relss[ r[0] - T_EQ ] ); + /* + * for [] and strings, comparisons are done on + * the maximum width of the two sides. + * for other sets, we have to ask the left side + * what type it is based on the type of the right. + * (this matters for intsets). + */ + if ( p1 == nl + TSET || c1 == TSTR ) { + codeoff(); + p = rvalue( r[ 2 ] , NIL , LREQ ); + codeon(); + if ( p1 == nl + TSET + || lwidth( p ) > lwidth( p1 ) ) { + contype = p; + } + } else { + codeoff(); + p = rvalue( r[ 2 ] , contype , LREQ ); + codeon(); + contype = p; + } + if ( p == NIL ) { + return NIL; + } + /* + * put out the width of the comparison. + */ + putleaf( P2ICON , lwidth( contype ) , 0 , P2INT , 0 ); + /* + * and the left hand side, + * for sets, strings, records + */ + p = rvalue( r[ 2 ] , contype , LREQ ); + putop( P2LISTOP , P2INT ); + p1 = rvalue( r[ 3 ] , p , LREQ ); + putop( P2LISTOP , P2INT ); + putop( P2CALL , P2INT ); + } else { + /* + * the easy (scalar or error) case + */ + p = rvalue( r[ 2 ] , contype , RREQ ); + if ( p == NIL ) { + return NIL; + /* + * since the second pass can't do + * long op double or double op long + * we may have to do some coercing. + */ + if ( isa( p , "i" ) && isa( p1 , "d" ) ) + putop( P2SCONV , P2DOUBLE ); + } + p1 = rvalue( r[ 3 ] , p , RREQ ); + if ( isa( p , "d" ) && isa( p1 , "i" ) ) + putop( P2SCONV , P2DOUBLE ); + putop( relops[ r[0] - T_EQ ] , P2INT ); + } +# endif PC + c = classify(p); + c1 = classify(p1); + if (nocomp(c) || nocomp(c1)) + return (NIL); + g = NIL; + switch (c) { + case TBOOL: + case TCHAR: + if (c != c1) + goto clash; + break; + case TINT: + case TDOUBLE: + if (c1 != TINT && c1 != TDOUBLE) + goto clash; + break; + case TSCAL: + if (c1 != TSCAL) + goto clash; + if (scalar(p) != scalar(p1)) + goto nonident; + break; + case TSET: + if (c1 != TSET) + goto clash; + if (p != p1) + goto nonident; + g = TSET; + break; + case TREC: + if ( c1 != TREC ) { + goto clash; + } + if ( p != p1 ) { + goto nonident; + } + if (r[0] != T_EQ && r[0] != T_NE) { + error("%s not allowed on records - only allow = and <>" , opname ); + return (NIL); + } + g = TREC; + break; + case TPTR: + case TNIL: + if (c1 != TPTR && c1 != TNIL) + goto clash; + if (r[0] != T_EQ && r[0] != T_NE) { + error("%s not allowed on pointers - only allow = and <>" , opname ); + return (NIL); + } + break; + case TSTR: + if (c1 != TSTR) + goto clash; + if (width(p) != width(p1)) { + error("Strings not same length in %s comparison", opname); + return (NIL); + } + g = TSTR; + break; + default: + panic("rval2"); + } +# ifdef OBJ + return (gen(g, r[0], width(p), width(p1))); +# endif OBJ +# ifdef PC + return nl + TBOOL; +# endif PC +clash: + error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname); + return (NIL); +nonident: + error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname); + return (NIL); + + case T_IN: + rt = r[3]; +# ifdef OBJ + if (rt != NIL && rt[0] == T_CSET) { + precset( rt , NIL , &csetd ); + p1 = csetd.csettype; + if (p1 == NIL) + return NIL; + if (p1 == nl+TSET) { + if ( !inempty ) { + warning(); + error("... in [] makes little sense, since it is always false!"); + inempty = TRUE; + } + put(1, O_CON1, 0); + return (nl+T1BOOL); + } + postcset( rt, &csetd); + } else { + p1 = stkrval(r[3], NIL , RREQ ); + rt = NIL; + } +# endif OBJ +# ifdef PC + if (rt != NIL && rt[0] == T_CSET) { + if ( precset( rt , NIL , &csetd ) ) { + if ( csetd.csettype != nl + TSET ) { + putleaf( P2ICON , 0 , 0 + , ADDTYPE( P2FTN | P2INT , P2PTR ) + , "_IN" ); + } + } else { + putleaf( P2ICON , 0 , 0 + , ADDTYPE( P2FTN | P2INT , P2PTR ) + , "_INCT" ); + } + p1 = csetd.csettype; + if (p1 == NIL) + return NIL; + if ( p1 == nl + TSET ) { + if ( !inempty ) { + warning(); + error("... in [] makes little sense, since it is always false!"); + inempty = TRUE; + } + putleaf( P2ICON , 0 , 0 , P2INT , 0 ); + return (nl+T1BOOL); + } + } else { + putleaf( P2ICON , 0 , 0 + , ADDTYPE( P2FTN | P2INT , P2PTR ) + , "_IN" ); + codeoff(); + p1 = rvalue(r[3], NIL , LREQ ); + codeon(); + } +# endif PC + p = stkrval(r[2], NIL , RREQ ); + if (p == NIL || p1 == NIL) + return (NIL); + if (p1->class != SET) { + error("Right operand of 'in' must be a set, not %s", nameof(p1)); + return (NIL); + } + if (incompat(p, p1->type, r[2])) { + cerror("Index type clashed with set component type for 'in'"); + return (NIL); + } + setran(p1->type); +# ifdef OBJ + if (rt == NIL || csetd.comptime) + put(4, O_IN, width(p1), set.lwrb, set.uprbp); + else + put(2, O_INCT, 3 + csetd.singcnt + 2*csetd.paircnt); +# endif OBJ +# ifdef PC + if ( rt == NIL || rt[0] != T_CSET ) { + putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 ); + putop( P2LISTOP , P2INT ); + putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 ); + putop( P2LISTOP , P2INT ); + p1 = rvalue( r[3] , NIL , LREQ ); + putop( P2LISTOP , P2INT ); + } else if ( csetd.comptime ) { + putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 ); + putop( P2LISTOP , P2INT ); + putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 ); + putop( P2LISTOP , P2INT ); + postcset( r[3] , &csetd ); + putop( P2LISTOP , P2INT ); + } else { + postcset( r[3] , &csetd ); + } + putop( P2CALL , P2INT ); +# endif PC + return (nl+T1BOOL); + default: + if (r[2] == NIL) + return (NIL); + switch (r[0]) { + default: + panic("rval3"); + + + /* + * An octal number + */ + case T_BINT: + f = a8tol(r[2]); + goto conint; + + /* + * A decimal number + */ + case T_INT: + f = atof(r[2]); +conint: + if (f > MAXINT || f < MININT) { + error("Constant too large for this implementation"); + return (NIL); + } + l = f; + if (bytes(l, l) <= 2) { +# ifdef OBJ + put(2, O_CON2, ( short ) l); +# endif OBJ +# ifdef PC + /* + * short constants are ints + */ + putleaf( P2ICON , l , 0 , P2INT , 0 ); +# endif PC + return (nl+T2INT); + } +# ifdef OBJ + put(2, O_CON4, l); +# endif OBJ +# ifdef PC + putleaf( P2ICON , l , 0 , P2INT , 0 ); +# endif PC + return (nl+T4INT); + + /* + * A floating point number + */ + case T_FINT: +# ifdef OBJ + put(2, O_CON8, atof(r[2])); +# endif OBJ +# ifdef PC + putCON8( atof( r[2] ) ); +# endif PC + return (nl+TDOUBLE); + + /* + * Constant strings. Note that constant characters + * are constant strings of length one; there is + * no constant string of length one. + */ + case T_STRNG: + cp = r[2]; + if (cp[1] == 0) { +# ifdef OBJ + put(2, O_CONC, cp[0]); +# endif OBJ +# ifdef PC + putleaf( P2ICON , cp[0] , 0 , P2CHAR , 0 ); +# endif PC + return (nl+T1CHAR); + } + goto cstrng; + } + + } +} + +/* + * Can a class appear + * in a comparison ? + */ +nocomp(c) + int c; +{ + + switch (c) { + case TREC: + if ( opt( 's' ) ) { + standard(); + error("record comparison is non-standard"); + } + break; + case TFILE: + case TARY: + error("%ss may not participate in comparisons", clnames[c]); + return (1); + } + return (NIL); +} + + /* + * this is sort of like gconst, except it works on expression trees + * rather than declaration trees, and doesn't give error messages for + * non-constant things. + * as a side effect this fills in the con structure that gconst uses. + * this returns TRUE or FALSE. + */ +constval(r) + register int *r; +{ + register struct nl *np; + register *cn; + char *cp; + int negd, sgnd; + long ci; + + con.ctype = NIL; + cn = r; + negd = sgnd = 0; +loop: + /* + * cn[2] is nil if error recovery generated a T_STRNG + */ + if (cn == NIL || cn[2] == NIL) + return FALSE; + switch (cn[0]) { + default: + return FALSE; + case T_MINUS: + negd = 1 - negd; + /* and fall through */ + case T_PLUS: + sgnd++; + cn = cn[2]; + goto loop; + case T_NIL: + con.cpval = NIL; + con.cival = 0; + con.crval = con.cival; + con.ctype = nl + TNIL; + break; + case T_VAR: + np = lookup(cn[2]); + if (np == NIL || np->class != CONST) { + return FALSE; + } + if ( cn[3] != NIL ) { + return FALSE; + } + con.ctype = np->type; + switch (classify(np->type)) { + case TINT: + con.crval = np->range[0]; + break; + case TDOUBLE: + con.crval = np->real; + break; + case TBOOL: + case TCHAR: + case TSCAL: + con.cival = np->value[0]; + con.crval = con.cival; + break; + case TSTR: + con.cpval = np->ptr[0]; + break; + default: + con.ctype = NIL; + return FALSE; + } + break; + case T_BINT: + con.crval = a8tol(cn[2]); + goto restcon; + case T_INT: + con.crval = atof(cn[2]); + if (con.crval > MAXINT || con.crval < MININT) { + derror("Constant too large for this implementation"); + con.crval = 0; + } +restcon: + ci = con.crval; +#ifndef PI0 + if (bytes(ci, ci) <= 2) + con.ctype = nl+T2INT; + else +#endif + con.ctype = nl+T4INT; + break; + case T_FINT: + con.ctype = nl+TDOUBLE; + con.crval = atof(cn[2]); + break; + case T_STRNG: + cp = cn[2]; + if (cp[1] == 0) { + con.ctype = nl+T1CHAR; + con.cival = cp[0]; + con.crval = con.cival; + break; + } + con.ctype = nl+TSTR; + con.cpval = cp; + break; + } + if (sgnd) { + if (isnta(con.ctype, "id")) { + derror("%s constants cannot be signed", nameof(con.ctype)); + return FALSE; + } else if (negd) + con.crval = -con.crval; + } + return TRUE; +} -- 2.20.1