X-Git-Url: https://git.subgeniuskitty.com/unix-history/.git/blobdiff_plain/2b84abb596f52ab2068d52108adc96838ad4340a..31cef89cb428866f787983e68246030321893df4:/usr/src/cmd/pi/rval.c diff --git a/usr/src/cmd/pi/rval.c b/usr/src/cmd/pi/rval.c index fb51694929..22849a80a6 100644 --- a/usr/src/cmd/pi/rval.c +++ b/usr/src/cmd/pi/rval.c @@ -1,29 +1,55 @@ /* Copyright (c) 1979 Regents of the University of California */ -# -/* - * pi - Pascal interpreter code translator - * - * Charles Haley, Bill Joy UCB - * Version 1.2 Novmeber 1978 - */ -#include "whoami" +static char sccsid[] = "@(#)rval.c 1.5 10/28/80"; + +#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[]; + + /* line number of the last record comparison warning */ +short reccompline = 0; + +#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) +rvalue(r, contype , required ) int *r; struct nl *contype; + int required; { register struct nl *p, *p1; register struct nl *q; @@ -31,6 +57,13 @@ rvalue(r, contype) 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); @@ -52,14 +85,24 @@ rvalue(r, contype) * The constant nil */ case T_NIL: - put2(O_CON2, 0); +# ifdef OBJ + put(2, O_CON2, 0); +# endif OBJ +# ifdef PC + putleaf( P2ICON , 0 , 0 , P2PTR|P2UNDEF , 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]); @@ -78,20 +121,35 @@ rvalue(r, contype) q = p->type; if (q == NIL) return (NIL); - w = width(q); - switch (w) { - case 8: - w = 6; - case 4: - case 2: - case 1: - put2(O_RV1 + (w >> 1) | bn << 9 - , p->value[0]); - break; - default: - put3(O_RV | bn << 9, p->value[0], w); - } - return (q); +# 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: @@ -101,27 +159,39 @@ rvalue(r, contype) * might consider a rvalue. */ ind: - q = lvalue(r, NOMOD); + q = lvalue(r, NOFLAGS , LREQ ); if (q == NIL) return (NIL); - w = width(q); - switch (w) { - case 8: - w = 6; - case 4: - case 2: - case 1: - put1(O_IND1 + (w >> 1)); - break; - default: - put2(O_IND, w); - } +# 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); + error("%s is a constant and cannot be qualified", r[2]); + return (NIL); } q = p->type; if (q == NIL) @@ -143,7 +213,13 @@ cstrng: } c = width(contype); } - put( 2 + (sizeof ( char * )/sizeof ( short )) , O_CONG, c, cp1); +# 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 @@ -155,7 +231,13 @@ cstrng: return (q); } if (q == nl+T1CHAR) { - put2(O_CONC, p->value[0]); +# 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); } /* @@ -164,25 +246,59 @@ cstrng: switch (width(q)) { case 8: #ifndef DEBUG - put(5, O_CON8, p->real); +# 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( 3 , O_CON4, l); + put(2, O_CON4, l); } else - put(5, O_CON8, p->real); +# ifdef OBJ + put(2, O_CON8, p->real); +# endif OBJ +# ifdef PC + putCON8( p -> real ); +# endif PC #endif break; case 4: - put( 3 , O_CON4, p->range[0]); +# 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: - put2(O_CON2, ( short ) p->range[0]); +# 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: - put2(O_CON1, p->value[0]); +# 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"); @@ -190,6 +306,7 @@ cstrng: return (q); case FUNC: + case FFUNC: /* * Function call with no arguments. */ @@ -197,13 +314,19 @@ cstrng: error("Can't qualify a function result value"); return (NIL); } - return (funccod((int *) r)); +# 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: + case FPROC: error("Procedure %s found where expression required", p->symbol); return (NIL); default: @@ -213,14 +336,59 @@ cstrng: * Constant sets */ case T_CSET: - return (cset(r, contype, NIL)); +# 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); + q = rvalue(r[2], NIL , RREQ ); if (q == NIL) return (NIL); if (isnta(q, "id")) { @@ -228,26 +396,36 @@ cstrng: return (NIL); } if (r[0] == T_MINUS) { - put1(O_NEG2 + (width(q) >> 2)); - return (isa(q, "d") ? q : nl+T4INT); +# 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); + 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); } - put1(O_NOT); +# 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); - p1 = rvalue(r[3], NIL); + p = rvalue(r[2], NIL , RREQ ); + p1 = rvalue(r[3], NIL , RREQ ); if (p == NIL || p1 == NIL) return (NIL); if (isnta(p, "b")) { @@ -258,12 +436,36 @@ cstrng: error("Right operand of %s must be Boolean, not %s", opname, nameof(p1)); return (NIL); } - put1(r[0] == T_AND ? O_AND : O_OR); +# 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: - p = rvalue(r[2], NIL); - p1 = rvalue(r[3], NIL); +# 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")) { @@ -274,45 +476,145 @@ cstrng: error("Right operand of / must be integer or real, not %s", nameof(p1)); return (NIL); } - return (gen(NIL, r[0], width(p), width(p1))); +# 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_SUB: case T_ADD: - /* - * 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); - codeon(); - if (contype == NIL) - return (NIL); - } - p = rvalue(r[2], contype); - p1 = rvalue(r[3], p); - if (p == NIL || p1 == NIL) - return (NIL); - if (isa(p, "id") && isa(p1, "id")) + case T_SUB: +# ifdef OBJ + /* + * If the context hasn't told us the type + * and a constant set is present + * we need to infer the type + * before generating code. + */ + if ( contype == NIL ) { + codeoff(); + contype = rvalue( r[3] , NIL , RREQ ); + codeon(); + if ( contype == lookup( intset ) -> type ) { + codeoff(); + contype = rvalue( r[2] , 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) { + 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 ] ); + if ( contype == NIL ) { + contype = p1; + if ( contype == lookup( intset ) -> type ) { + codeoff(); + contype = rvalue( r[2] , NIL , LREQ ); + codeon(); + } + } + if ( contype == NIL ) { + return NIL; + } + /* + * allocate a temporary and use it + */ + sizes[ cbn ].om_off -= lwidth( contype ); + 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] , contype , 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); + return NIL; + } + putop( P2LISTOP , P2INT ); + putleaf( P2ICON , lwidth( p1 ) / sizeof( long ) , 0 + , P2INT , 0 ); + putop( P2LISTOP , P2INT ); + putop( P2CALL , P2PTR | P2STRTY ); + return p; } - gen(TSET, r[0], width(p), 0); + } + if ( isnta( p1 , "idt" ) ) { + /* + * find type of left operand for error message. + */ + p = rvalue( r[2] , contype , RREQ ); + } /* - * Note that set was filled in by the call - * to width above. + * don't give spurious error messages. */ - if (r[0] == T_SUB) - put2(NIL, 0177777 << ((set.uprbp & 017) + 1)); - return (p); - } + 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); @@ -326,8 +628,8 @@ cstrng: case T_MOD: case T_DIV: - p = rvalue(r[2], NIL); - p1 = rvalue(r[3], NIL); + p = rvalue(r[2], NIL , RREQ ); + p1 = rvalue(r[3], NIL , RREQ ); if (p == NIL || p1 == NIL) return (NIL); if (isnta(p, "i")) { @@ -338,14 +640,20 @@ cstrng: error("Right operand of %s must be integer, not %s", opname, nameof(p1)); return (NIL); } - return (gen(NIL, r[0], width(p), width(p1))); +# 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_GE: - case T_LE: - case T_GT: 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 @@ -355,38 +663,118 @@ cstrng: * necessary. */ codeoff(); - p1 = rvalue(r[3], NIL); + p1 = rvalue(r[3], NIL , RREQ ); codeon(); if (p1 == NIL) return (NIL); contype = p1; - 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); - codeon(); - if (p == NIL) - return (NIL); - if (p1 == nl+TSET || width(p) > width(p1)) +# ifdef OBJ + if (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 (width(p) > width(p1)) + contype = p; + } else if ( isa( p1 , "t" ) ) { + if ( contype == lookup( intset ) -> type ) { + codeoff(); + contype = rvalue( r[2] , NIL , RREQ ); + codeon(); + if ( contype == NIL ) { + return NIL; + } + } + } + /* + * 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 ( c1 == TSTR ) { + codeoff(); + p = rvalue( r[ 2 ] , NIL , LREQ ); + codeon(); + if ( p == NIL ) { + return NIL; + } + if ( lwidth( p ) > lwidth( p1 ) ) { contype = p; - } - /* - * Now we generate code for - * the operands of the relational - * operation. - */ - p = rvalue(r[2], contype); - if (p == NIL) - return (NIL); - p1 = rvalue(r[3], p); - if (p1 == NIL) - return (NIL); + } + } else if ( c1 == TSET ) { + if ( contype == lookup( intset ) -> type ) { + codeoff(); + p = rvalue( r[ 2 ] , NIL , LREQ ); + codeon(); + if ( p == NIL ) { + return NIL; + } + contype = p; + } + } + /* + * 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)) @@ -416,12 +804,25 @@ cstrng: 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 <>"); + error("%s not allowed on pointers - only allow = and <>" , opname ); return (NIL); } break; @@ -437,7 +838,12 @@ cstrng: default: panic("rval2"); } - return (gen(g, r[0], width(p), width(p1))); +# 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); @@ -446,20 +852,43 @@ nonident: return (NIL); case T_IN: - rt = r[3]; - if (rt != NIL && rt[0] == T_CSET) - p1 = cset(rt, NLNIL, 1); - else { - p1 = rvalue(r[3], NIL); + rt = r[3]; +# ifdef OBJ + if (rt != NIL && rt[0] == T_CSET) { + precset( rt , NIL , &csetd ); + p1 = csetd.csettype; + if (p1 == NIL) + return NIL; + postcset( rt, &csetd); + } else { + p1 = stkrval(r[3], NIL , RREQ ); rt = NIL; - } - if (p1 == nl+TSET) { - warning(); - error("... in [] makes little sense, since it is always false!"); - put1(O_CON1, 0); - return (nl+T1BOOL); - } - p = rvalue(r[2], NIL); + } +# endif OBJ +# ifdef PC + if (rt != NIL && rt[0] == T_CSET) { + if ( precset( rt , NIL , &csetd ) ) { + 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; + } 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) { @@ -470,14 +899,34 @@ nonident: cerror("Index type clashed with set component type for 'in'"); return (NIL); } - convert(p, nl+T2INT); setran(p1->type); - if (rt == NIL) - put4(O_IN, width(p1), set.lwrb, set.uprbp); - else - put1(O_INCT); +# 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); @@ -505,17 +954,35 @@ conint: } l = f; if (bytes(l, l) <= 2) { - put2(O_CON2, ( short ) l); +# 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); } - put( 3 , O_CON4, l); +# 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: - put(5, O_CON8, atof(r[2])); +# ifdef OBJ + put(2, O_CON8, atof(r[2])); +# endif OBJ +# ifdef PC + putCON8( atof( r[2] ) ); +# endif PC return (nl+TDOUBLE); /* @@ -526,7 +993,12 @@ conint: case T_STRNG: cp = r[2]; if (cp[1] == 0) { - put2(O_CONC, cp[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; @@ -544,11 +1016,135 @@ nocomp(c) { switch (c) { + case TREC: + if ( line != reccompline ) { + reccompline = line; + warning(); + if ( opt( 's' ) ) { + standard(); + } + error("record comparison is non-standard"); + } + break; case TFILE: case TARY: - case TREC: 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; +}