/* Copyright (c) 1979 Regents of the University of California */
static char sccsid
[] = "@(#)rval.c 1.20 %G%";
/* line number of the last record comparison warning */
/* line number of the last non-standard set comparison */
long mathop
[] = { P2MUL
, P2PLUS
, P2MINUS
};
char *setop
[] = { "_MULT" , "_ADDT" , "_SUBT" };
* 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.
rvalue(r
, contype
, required
)
register struct nl
*p
, *p1
;
* Pick up the name of the operation
* for future error messages.
opname
= opnames
[r
->tag
];
* The root of the tree tells us what sort of expression we have.
(void) put(2, O_CON2
, 0);
putleaf( P2ICON
, 0 , 0 , P2PTR
|P2UNDEF
, (char *) 0 );
* Function call with arguments.
p
= lookup(r
->var_node
.cptr
);
if (p
== NLNIL
|| p
->class == BADUSE
)
if (r
->var_node
.qual
!= TR_NIL
)
(void) put(2, O_RV8
| bn
<< 8+INDX
,
(void) put(2, O_RV4
| bn
<< 8+INDX
,
(void) put(2, O_RV2
| bn
<< 8+INDX
,
(void) put(2, O_RV1
| bn
<< 8+INDX
,
(void) put(3, O_RV
| bn
<< 8+INDX
,
if ( required
== RREQ
) {
putRV( p
-> symbol
, bn
, p
-> value
[0] ,
p
-> extra_flags
, p2type( q
) );
putLV( p
-> symbol
, bn
, p
-> value
[0] ,
p
-> extra_flags
, p2type( q
) );
* might consider a rvalue.
q
= lvalue(r
, NOFLAGS
, LREQ
);
if ( required
== RREQ
) {
putop( P2UNARY P2MUL
, p2type( q
) );
if (r
->var_node
.qual
!= TR_NIL
) {
error("%s is a constant and cannot be qualified", r
->var_node
.cptr
);
* Find the size of the string
if (contype
!= NIL
&& !opt('s')) {
if (width(contype
) < c
&& classify(contype
) == TSTR
) {
error("Constant string too long");
(void) put(2, O_CONG
, w
);
putCONG( cp1
, w
, required
);
* Define the string temporarily
* so later people can know its
q
= defnl((char *) 0, STR
, NLNIL
, w
);
(void) put(2, O_CONC
, (int)p
->value
[0]);
putleaf( P2ICON
, p
-> value
[0] , 0
* Every other kind of constant here
(void) put(2, O_CON8
, p
->real
);
conv((int *) (&f
.pdouble
));
(void) put(2, O_CON4
, l
);
(void) put(2, O_CON8
, p
->real
);
(void) put(2, O_CON4
, p
->range
[0]);
putleaf( P2ICON
, (int) p
->range
[0] , 0
(void) put(2, O_CON2
, (short)p
->range
[0]);
putleaf( P2ICON
, (short) p
-> range
[0]
, 0 , P2SHORT
, (char *) 0 );
(void) put(2, O_CON1
, p
->value
[0]);
putleaf( P2ICON
, p
-> value
[0] , 0
* Function call with no arguments.
if (r
->var_node
.qual
!= TR_NIL
) {
error("Can't qualify a function result value");
error("Type names (e.g. %s) allowed only in declarations", p
->symbol
);
error("Procedure %s found where expression required", p
->symbol
);
if ( precset( r
, contype
, &csetd
) ) {
if ( csetd
.csettype
== NIL
) {
(void) put( 2, O_PUSH
, -lwidth(csetd
.csettype
));
setran( ( csetd
.csettype
) -> type
);
(void) put( 2, O_CON24
, set
.uprbp
);
(void) put( 2, O_CON24
, set
.lwrb
);
(int)(4 + csetd
.singcnt
+ 2 * csetd
.paircnt
));
if ( precset( r
, contype
, &csetd
) ) {
if ( csetd
.csettype
== NIL
) {
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
* allocate a temporary and use it
tempnlp
= tmpalloc(lwidth(csetd
.csettype
),
putLV( (char *) 0 , cbn
, tempnlp
-> value
[ NL_OFFS
] ,
tempnlp
-> extra_flags
, P2PTR
|P2STRTY
);
setran( ( csetd
.csettype
) -> type
);
putleaf( P2ICON
, set
.lwrb
, 0 , P2INT
, (char *) 0 );
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, set
.uprbp
, 0 , P2INT
, (char *) 0 );
putop( P2LISTOP
, P2INT
);
q
= rvalue(r
->un_expr
.expr
, NLNIL
, RREQ
);
error("Operand of %s must be integer or real, not %s", opname
, nameof(q
));
(void) put(1, O_NEG2
+ (width(q
) >> 2));
return (isa(q
, "d") ? q
: nl
+T4INT
);
putop( P2UNARY P2MINUS
, P2INT
);
putop( P2UNARY P2MINUS
, P2DOUBLE
);
q
= rvalue(r
->un_expr
.expr
, NLNIL
, RREQ
);
error("not must operate on a Boolean, not %s", nameof(q
));
p
= rvalue(r
->expr_node
.lhs
, NLNIL
, RREQ
);
p1
= rvalue(r
->expr_node
.rhs
, NLNIL
, RREQ
);
if (p
== NLNIL
|| p1
== NLNIL
)
error("Left operand of %s must be Boolean, not %s", opname
, nameof(p
));
error("Right operand of %s must be Boolean, not %s", opname
, nameof(p1
));
(void) put(1, r
->tag
== T_AND
? O_AND
: O_OR
);
* note the use of & and | rather than && and ||
* to force evaluation of all the expressions.
putop( r
->tag
== T_AND
? P2AND
: P2OR
, P2INT
);
p
= rvalue(r
->expr_node
.lhs
, NLNIL
, RREQ
);
p1
= rvalue(r
->expr_node
.rhs
, NLNIL
, RREQ
);
* force these to be doubles for the divide
p
= rvalue( r
->expr_node
.lhs
, NLNIL
, RREQ
);
sconv(p2type(p
), P2DOUBLE
);
p1
= rvalue( r
->expr_node
.rhs
, NLNIL
, RREQ
);
sconv(p2type(p1
), P2DOUBLE
);
if (p
== NLNIL
|| p1
== NLNIL
)
error("Left operand of / must be integer or real, not %s", nameof(p
));
error("Right operand of / must be integer or real, not %s", nameof(p1
));
return gen(NIL
, r
->tag
, width(p
), width(p1
));
putop( P2DIV
, P2DOUBLE
);
* 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
== NLNIL
) {
contype
= rvalue( r
->expr_node
.rhs
, NLNIL
, RREQ
);
if ( contype
== NLNIL
) {
p
= rvalue( r
->expr_node
.lhs
, contype
, RREQ
);
p1
= rvalue( r
->expr_node
.rhs
, p
, RREQ
);
if ( p
== NLNIL
|| p1
== NLNIL
)
if (isa(p
, "id") && isa(p1
, "id"))
return (gen(NIL
, r
->tag
, width(p
), width(p1
)));
if (isa(p
, "t") && isa(p1
, "t")) {
error("Set types of operands of %s must be identical", opname
);
(void) gen(TSET
, r
->tag
, width(p
), 0);
* 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
p1
= rvalue( r
->expr_node
.rhs
, contype
, RREQ
);
if ( isa( p1
, "id" ) ) {
p
= rvalue( r
->expr_node
.lhs
, contype
, RREQ
);
if ( ( p
== NLNIL
) || ( p1
== NLNIL
) ) {
tuac(p
, p1
, &rettype
, (int *) (&ctype
));
p1
= rvalue( r
->expr_node
.rhs
, contype
, RREQ
);
tuac(p1
, p
, &rettype
, (int *) (&ctype
));
putop( (int) mathop
[r
->tag
- T_MULT
], (int) ctype
);
, ADDTYPE( ADDTYPE( P2PTR
| P2STRTY
, P2FTN
)
, setop
[ r
->tag
- T_MULT
] );
contype
= rvalue( r
->expr_node
.lhs
, p1
, LREQ
);
if ( contype
== NLNIL
) {
* allocate a temporary and use it
tempnlp
= tmpalloc(lwidth(contype
), contype
, NOREG
);
putLV((char *) 0 , cbn
, tempnlp
-> value
[ NL_OFFS
] ,
tempnlp
-> extra_flags
, P2PTR
|P2STRTY
);
p
= rvalue( r
->expr_node
.lhs
, contype
, LREQ
);
putop( P2LISTOP
, P2INT
);
if ( p
== NLNIL
|| p1
== NLNIL
) {
p1
= rvalue( r
->expr_node
.rhs
, p
, LREQ
);
error("Set types of operands of %s must be identical", opname
);
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, (int) (lwidth(p1
)) / sizeof( long ) , 0
putop( P2LISTOP
, P2INT
);
putop( P2CALL
, P2PTR
| P2STRTY
);
if ( isnta( p1
, "idt" ) ) {
* find type of left operand for error message.
p
= rvalue( r
->expr_node
.lhs
, contype
, RREQ
);
* don't give spurious error messages.
if ( p
== NLNIL
|| p1
== NLNIL
) {
error("Left operand of %s must be integer, real or set, not %s", opname
, nameof(p
));
error("Right operand of %s must be integer, real or set, not %s", opname
, nameof(p1
));
error("Cannot mix sets with integers and reals as operands of %s", opname
);
p
= rvalue(r
->expr_node
.lhs
, NLNIL
, RREQ
);
p1
= rvalue(r
->expr_node
.rhs
, NLNIL
, RREQ
);
sconv(p2type(p1
), P2INT
);
if (p
== NLNIL
|| p1
== NLNIL
)
error("Left operand of %s must be integer, not %s", opname
, nameof(p
));
error("Right operand of %s must be integer, not %s", opname
, nameof(p1
));
return (gen(NIL
, r
->tag
, width(p
), width(p1
)));
putop( r
->tag
== T_DIV
? P2DIV
: P2MOD
, P2INT
);
* 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
p1
= rvalue(r
->expr_node
.rhs
, NLNIL
, RREQ
);
* 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.
p
= rvalue(r
->expr_node
.lhs
, NLNIL
, RREQ
);
if (width(p
) > width(p1
))
* Now we generate code for
* the operands of the relational
p
= rvalue(r
->expr_node
.lhs
, contype
, RREQ
);
p1
= rvalue(r
->expr_node
.rhs
, p
, RREQ
);
if ( c1
== TSET
|| c1
== TSTR
|| c1
== TREC
) {
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
, c1
== TSET
? relts
[ r
->tag
- T_EQ
]
: relss
[ r
->tag
- 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).
p
= rvalue( r
->expr_node
.lhs
, NLNIL
, LREQ
);
if ( lwidth( p
) > lwidth( p1
) ) {
} else if ( c1
== TSET
) {
p
= rvalue( r
->expr_node
.lhs
, contype
, LREQ
);
* put out the width of the comparison.
putleaf(P2ICON
, (int) lwidth(contype
), 0, P2INT
, (char *) 0);
* and the left hand side,
* for sets, strings, records
p
= rvalue( r
->expr_node
.lhs
, contype
, LREQ
);
putop( P2LISTOP
, P2INT
);
p1
= rvalue( r
->expr_node
.rhs
, p
, LREQ
);
putop( P2LISTOP
, P2INT
);
* the easy (scalar or error) case
p
= rvalue( r
->expr_node
.lhs
, contype
, RREQ
);
* since the second pass can't do
* long op double or double op long
* we may have to do some coercing.
tuac(p
, p1
, &rettype
, (int *) (&ctype
));
p1
= rvalue( r
->expr_node
.rhs
, p
, RREQ
);
tuac(p1
, p
, &rettype
, (int *) (&ctype
));
putop((int) relops
[ r
->tag
- T_EQ
] , P2INT
);
if (nocomp(c
) || nocomp(c1
))
if (c1
!= TINT
&& c1
!= TDOUBLE
)
if (scalar(p
) != scalar(p1
))
( ( r
->tag
== T_LT
) || (r
->tag
== T_GT
) ) &&
( line
!= nssetline
) ) {
error("%s comparison on sets is non-standard" , opname
);
if (r
->tag
!= T_EQ
&& r
->tag
!= T_NE
) {
error("%s not allowed on records - only allow = and <>" , opname
);
if (c1
!= TPTR
&& c1
!= TNIL
)
if (r
->tag
!= T_EQ
&& r
->tag
!= T_NE
) {
error("%s not allowed on pointers - only allow = and <>" , opname
);
if (p
!= nl
+TNIL
&& p1
!= nl
+TNIL
&& p
!= p1
)
if (width(p
) != width(p1
)) {
error("Strings not same length in %s comparison", opname
);
return (gen(g
, r
->tag
, width(p
), width(p1
)));
error("%ss and %ss cannot be compared - operator was %s", clnames
[c
], clnames
[c1
], opname
);
error("%s types must be identical in comparisons - operator was %s", clnames
[c1
], opname
);
if (rt
!= TR_NIL
&& rt
->tag
== T_CSET
) {
(void) precset( rt
, NLNIL
, &csetd
);
p1
= stkrval(r
->expr_node
.rhs
, NLNIL
, (long) RREQ
);
if (rt
!= TR_NIL
&& rt
->tag
== T_CSET
) {
if ( precset( rt
, NLNIL
, &csetd
) ) {
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
p1
= rvalue(r
->expr_node
.rhs
, NLNIL
, LREQ
);
p
= stkrval(r
->expr_node
.lhs
, NLNIL
, (long) RREQ
);
if (p
== NIL
|| p1
== NIL
)
if (p1
->class != (char) SET
) {
error("Right operand of 'in' must be a set, not %s", nameof(p1
));
if (incompat(p
, p1
->type
, r
->expr_node
.lhs
)) {
cerror("Index type clashed with set component type for 'in'");
if (rt
== TR_NIL
|| csetd
.comptime
)
(void) put(4, O_IN
, width(p1
), set
.lwrb
, set
.uprbp
);
(int)(3 + csetd
.singcnt
+ 2*csetd
.paircnt
));
if ( rt
== TR_NIL
|| rt
->tag
!= T_CSET
) {
putleaf( P2ICON
, set
.lwrb
, 0 , P2INT
, (char *) 0 );
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, set
.uprbp
, 0 , P2INT
, (char *) 0 );
putop( P2LISTOP
, P2INT
);
p1
= rvalue( r
->expr_node
.rhs
, NLNIL
, LREQ
);
putop( P2LISTOP
, P2INT
);
} else if ( csetd
.comptime
) {
putleaf( P2ICON
, set
.lwrb
, 0 , P2INT
, (char *) 0 );
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, set
.uprbp
, 0 , P2INT
, (char *) 0 );
putop( P2LISTOP
, P2INT
);
postcset( r
->expr_node
.rhs
, &csetd
);
putop( P2LISTOP
, P2INT
);
postcset( r
->expr_node
.rhs
, &csetd
);
if (r
->expr_node
.lhs
== TR_NIL
)
f
.pdouble
= a8tol(r
->const_node
.cptr
);
f
.pdouble
= atof(r
->const_node
.cptr
);
if (f
.pdouble
> MAXINT
|| f
.pdouble
< MININT
) {
error("Constant too large for this implementation");
(void) put(2, O_CON2
, ( short ) l
);
(void) put(2, O_CON4
, l
);
putleaf(P2ICON
, (int) l
, 0, P2CHAR
,
putleaf(P2ICON
, (int) l
, 0, P2SHORT
,
putleaf(P2ICON
, (int) l
, 0, P2INT
,
* A floating point number
(void) put(2, O_CON8
, atof(r
->const_node
.cptr
));
putCON8( atof( r
->const_node
.cptr
) );
* Constant strings. Note that constant characters
* are constant strings of length one; there is
* no constant string of length one.
(void) put(2, O_CONC
, cp
[0]);
putleaf( P2ICON
, cp
[0] , 0 , P2CHAR
,
if ( line
!= reccompline
) {
error("record comparison is non-standard");
error("%ss may not participate in comparisons", clnames
[c
]);
* this is sort of like gconst, except it works on expression trees
* rather than declaration trees, and doesn't give error messages for
* as a side effect this fills in the con structure that gconst uses.
* this returns TRUE or FALSE.
register struct tnode
*r
;
register struct tnode
*cn
;
* cn[2] is nil if error recovery generated a T_STRNG
if (cn
== TR_NIL
|| cn
->expr_node
.lhs
== TR_NIL
)
np
= lookup(cn
->var_node
.cptr
);
if (np
== NLNIL
|| np
->class != CONST
) {
if ( cn
->var_node
.qual
!= TR_NIL
) {
switch (classify(np
->type
)) {
con
.crval
= np
->range
[0];
con
.cival
= np
->value
[0];
con
.cpval
= (char *) np
->ptr
[0];
con
.crval
= a8tol(cn
->const_node
.cptr
);
con
.crval
= atof(cn
->const_node
.cptr
);
if (con
.crval
> MAXINT
|| con
.crval
< MININT
) {
derror("Constant too large for this implementation");
con
.crval
= atof(cn
->const_node
.cptr
);
cp
= cn
->const_node
.cptr
;
if (isnta(con
.ctype
, "id")) {
derror("%s constants cannot be signed", nameof(con
.ctype
));