rval.c

早期freebsd实现

#		endif PC

	/*
	 * Unary plus and minus
	 */
	case T_PLUS:
	case T_MINUS:
		q = rvalue(r->un_expr.expr, NLNIL , RREQ );
		if (q == NLNIL)
			return (NLNIL);
		if (isnta(q, "id")) {
			error("Operand of %s must be integer or real, not %s", opname, nameof(q));
			return (NLNIL);
		}
		if (r->tag == T_MINUS) {
#		    ifdef OBJ
			(void) put(1, O_NEG2 + (width(q) >> 2));
			return (isa(q, "d") ? q : nl+T4INT);
#		    endif OBJ
#		    ifdef PC
			if (isa(q, "i")) {
			    sconv(p2type(q), PCCT_INT);
			    putop( PCCOM_UNARY PCC_MINUS, PCCT_INT);
			    return nl+T4INT;
			}
			putop( PCCOM_UNARY PCC_MINUS, PCCT_DOUBLE);
			return nl+TDOUBLE;
#		    endif PC
		}
		return (q);

	case T_NOT:
		q = rvalue(r->un_expr.expr, NLNIL , RREQ );
		if (q == NLNIL)
			return (NLNIL);
		if (isnta(q, "b")) {
			error("not must operate on a Boolean, not %s", nameof(q));
			return (NLNIL);
		}
#		ifdef OBJ
		    (void) put(1, O_NOT);
#		endif OBJ
#		ifdef PC
		    sconv(p2type(q), PCCT_INT);
		    putop( PCC_NOT , PCCT_INT);
		    sconv(PCCT_INT, p2type(q));
#		endif PC
		return (nl+T1BOOL);

	case T_AND:
	case T_OR:
		p = rvalue(r->expr_node.lhs, NLNIL , RREQ );
#		ifdef PC
		    sconv(p2type(p),PCCT_INT);
#		endif PC
		p1 = rvalue(r->expr_node.rhs, NLNIL , RREQ );
#		ifdef PC
		    sconv(p2type(p1),PCCT_INT);
#		endif PC
		if (p == NLNIL || p1 == NLNIL)
			return (NLNIL);
		if (isnta(p, "b")) {
			error("Left operand of %s must be Boolean, not %s", opname, nameof(p));
			return (NLNIL);
		}
		if (isnta(p1, "b")) {
			error("Right operand of %s must be Boolean, not %s", opname, nameof(p1));
			return (NLNIL);
		}
#		ifdef OBJ
		    (void) put(1, r->tag == 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->tag == T_AND ? PCC_AND : PCC_OR , PCCT_INT );
		    sconv(PCCT_INT, p2type(p));
#		endif PC
		return (nl+T1BOOL);

	case T_DIVD:
#		ifdef OBJ
		    p = rvalue(r->expr_node.lhs, NLNIL , RREQ );
		    p1 = rvalue(r->expr_node.rhs, NLNIL , RREQ );
#		endif OBJ
#		ifdef PC
			/*
			 *	force these to be doubles for the divide
			 */
		    p = rvalue( r->expr_node.lhs , NLNIL , RREQ );
		    sconv(p2type(p), PCCT_DOUBLE);
		    p1 = rvalue( r->expr_node.rhs , NLNIL , RREQ );
		    sconv(p2type(p1), PCCT_DOUBLE);
#		endif PC
		if (p == NLNIL || p1 == NLNIL)
			return (NLNIL);
		if (isnta(p, "id")) {
			error("Left operand of / must be integer or real, not %s", nameof(p));
			return (NLNIL);
		}
		if (isnta(p1, "id")) {
			error("Right operand of / must be integer or real, not %s", nameof(p1));
			return (NLNIL);
		}
#		ifdef OBJ
		    return gen(NIL, r->tag, width(p), width(p1));
#		endif OBJ
#		ifdef PC
		    putop( PCC_DIV , PCCT_DOUBLE );
		    return nl + TDOUBLE;
#		endif PC

	case T_MULT:
	case T_ADD:
	case T_SUB:
#		ifdef OBJ
		    /*
		     * get the type of the right hand side.
		     * if it turns out to be a set,
		     * use that type when getting
		     * the type of the left hand side.
		     * and then use the type of the left hand side
		     * when generating code.
		     * this will correctly decide the type of any
		     * empty sets in the tree, since if the empty set 
		     * is on the left hand side it will inherit
		     * the type of the right hand side,
		     * and if it's on the right hand side, its type (intset)
		     * will be overridden by the type of the left hand side.
		     * this is an awful lot of tree traversing, 
		     * but it works.
		     */
		    codeoff();
		    p1 = rvalue( r->expr_node.rhs , NLNIL , RREQ );
		    codeon();
		    if ( p1 == NLNIL ) {
			return NLNIL;
		    }
		    if (isa(p1, "t")) {
			codeoff();
			contype = rvalue(r->expr_node.lhs, p1, RREQ);
			codeon();
			if (contype == NLNIL) {
			    return NLNIL;
			}
		    }
		    p = rvalue( r->expr_node.lhs , contype , RREQ );
		    p1 = rvalue( r->expr_node.rhs , p , RREQ );
		    if ( p == NLNIL || p1 == NLNIL )
			    return NLNIL;
		    if (isa(p, "id") && isa(p1, "id"))
			return (gen(NIL, r->tag, 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 (NLNIL);
			    }
			    (void) gen(TSET, r->tag, 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, see the note for obj above on determining
			 * the type of empty sets.
			 */
		    codeoff();
		    p1 = rvalue(r->expr_node.rhs, NLNIL, RREQ);
		    codeon();
		    if ( isa( p1 , "id" ) ) {
			p = rvalue( r->expr_node.lhs , contype , RREQ );
			if ( ( p == NLNIL ) || ( p1 == NLNIL ) ) {
			    return NLNIL;
			}
			tuac(p, p1, &rettype, (int *) (&ctype));
			p1 = rvalue( r->expr_node.rhs , contype , RREQ );
			tuac(p1, p, &rettype, (int *) (&ctype));
			if ( isa( p , "id" ) ) {
			    putop( (int) mathop[r->tag - T_MULT], (int) ctype);
			    return rettype;
			}
		    }
		    if ( isa( p1 , "t" ) ) {
			putleaf( PCC_ICON , 0 , 0
			    , PCCM_ADDTYPE( PCCM_ADDTYPE( PCCTM_PTR | PCCT_STRTY , PCCTM_FTN )
					, PCCTM_PTR )
			    , setop[ r->tag - T_MULT ] );
			codeoff();
			contype = rvalue( r->expr_node.lhs, p1 , LREQ );
			codeon();
			if ( contype == NLNIL ) {
			    return NLNIL;
			}
			    /*
			     *	allocate a temporary and use it
			     */
			tempnlp = tmpalloc(lwidth(contype), contype, NOREG);
			putLV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
				tempnlp -> extra_flags , PCCTM_PTR|PCCT_STRTY );
			p = rvalue( r->expr_node.lhs , contype , LREQ );
			if ( isa( p , "t" ) ) {
			    putop( PCC_CM , PCCT_INT );
			    if ( p == NLNIL || p1 == NLNIL ) {
				return NLNIL;
			    }
			    p1 = rvalue( r->expr_node.rhs , p , LREQ );
			    if ( p != p1 ) {
				error("Set types of operands of %s must be identical", opname);
				return NLNIL;
			    }
			    putop( PCC_CM , PCCT_INT );
			    putleaf( PCC_ICON , (int) (lwidth(p1)) / sizeof( long ) , 0
				    , PCCT_INT , (char *) 0 );
			    putop( PCC_CM , PCCT_INT );
			    putop( PCC_CALL , PCCTM_PTR | PCCT_STRTY );
			    return p;
			}
		    }
		    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 ) {
			return NLNIL;
		    }
#		endif PC
		if (isnta(p, "idt")) {
			error("Left operand of %s must be integer, real or set, not %s", opname, nameof(p));
			return (NLNIL);
		}
		if (isnta(p1, "idt")) {
			error("Right operand of %s must be integer, real or set, not %s", opname, nameof(p1));
			return (NLNIL);
		}
		error("Cannot mix sets with integers and reals as operands of %s", opname);
		return (NLNIL);

	case T_MOD:
	case T_DIV:
		p = rvalue(r->expr_node.lhs, NLNIL , RREQ );
#		ifdef PC
		    sconv(p2type(p), PCCT_INT);
#		ifdef tahoe
		    /* prepare for ediv workaround, see below. */
		    if (r->tag == T_MOD) {
			(void) rvalue(r->expr_node.lhs, NLNIL, RREQ);
			sconv(p2type(p), PCCT_INT);
		    }
#		endif tahoe
#		endif PC
		p1 = rvalue(r->expr_node.rhs, NLNIL , RREQ );
#		ifdef PC
		    sconv(p2type(p1), PCCT_INT);
#		endif PC
		if (p == NLNIL || p1 == NLNIL)
			return (NLNIL);
		if (isnta(p, "i")) {
			error("Left operand of %s must be integer, not %s", opname, nameof(p));
			return (NLNIL);
		}
		if (isnta(p1, "i")) {
			error("Right operand of %s must be integer, not %s", opname, nameof(p1));
			return (NLNIL);
		}
#		ifdef OBJ
		    return (gen(NIL, r->tag, width(p), width(p1)));
#		endif OBJ
#		ifdef PC
#		ifndef tahoe
		    putop( r->tag == T_DIV ? PCC_DIV : PCC_MOD , PCCT_INT );
		    return ( nl + T4INT );
#		else tahoe
		    putop( PCC_DIV , PCCT_INT );
		    if (r->tag == T_MOD) {
		    /*
		     * avoid f1 bug: PCC_MOD would generate an 'ediv',
		     * which would reuire too many registers to evaluate
		     * things like
		     * var i:boolean;j:integer; i := (j+1) = (j mod 2);
		     * so, instead of
		     *                PCC_MOD
		     *		        / \
		     *	               p   p1
		     * we put
		     *                  PCC_MINUS
		     *                    /   \
		     *			 p   PCC_MUL               
		     *			      /   \
		     *			  PCC_DIV  p1
		     *                      / \
		     *                     p  p1
		     *
		     * we already have put p, p, p1, PCC_DIV. and now...
		     */
			    rvalue(r->expr_node.rhs, NLNIL , RREQ );
			    sconv(p2type(p1), PCCT_INT);
			    putop( PCC_MUL, PCCT_INT );
			    putop( PCC_MINUS, PCCT_INT );
		    }
		    return ( nl + T4INT );
#		endif tahoe
#		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.
		 * see the note in the obj section of case T_MULT above
		 * for the determination of the base type of empty sets.
		 */
		codeoff();
		p1 = rvalue(r->expr_node.rhs, NLNIL , RREQ );
		codeon();
		if (p1 == NLNIL)
			return (NLNIL);
		contype = 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->expr_node.lhs, NLNIL , RREQ );
			    codeon();
			    if (p == NLNIL)
				    return (NLNIL);
			    if (width(p) > width(p1))
				    contype = p;
		    }
		    if (isa(p1, "t")) {
			codeoff();
			contype = rvalue(r->expr_node.lhs, p1, RREQ);
			codeon();
			if (contype == NLNIL) {
			    return NLNIL;
			}
		    }
		    /*
		     * Now we generate code for
		     * the operands of the relational
		     * operation.
		     */
		    p = rvalue(r->expr_node.lhs, contype , RREQ );
		    if (p == NLNIL)
			    return (NLNIL);
		    p1 = rvalue(r->expr_node.rhs, p , RREQ );
		    if (p1 == NLNIL)
			    return (NLNIL);
#		endif OBJ
#		ifdef PC
		    c1 = classify( p1 );
		    if ( c1 == TSET || c1 == TSTR || c1 == TREC ) {
			putleaf( PCC_ICON , 0 , 0
				, PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
				, 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).
			     */
			if ( c1 == TSTR ) {
			    codeoff();
			    p = rvalue( r->expr_node.lhs , NLNIL , LREQ );
			    codeon();
			    if ( p == NLNIL ) {
				return NLNIL;
			    }
			    if ( lwidth( p ) > lwidth( p1 ) ) {
				contype = p;
			    }
			} else if ( c1 == TSET ) {
			    codeoff();
			    contype = rvalue(r->expr_node.lhs, p1, LREQ);
			    codeon();
			    if (contype == NLNIL) {
				return NLNIL;
			    }
			} 
			    /*
			     *	put out the width of the comparison.
			     */
			putleaf(PCC_ICON, (int) lwidth(contype), 0, PCCT_INT, (char *) 0);
			    /*
			     *	and the left hand side,
			     *	for sets, strings, records
			     */
			p = rvalue( r->expr_node.lhs , contype , LREQ );
			if ( p == NLNIL ) {
			    return NLNIL;
			}
			putop( PCC_CM , PCCT_INT );
			p1 = rvalue( r->expr_node.rhs , p , LREQ );
			if ( p1 == NLNIL ) {
			    return NLNIL;
			}
			putop( PCC_CM , PCCT_INT );
			putop( PCC_CALL , PCCT_INT );
		    } else {
			    /*
			     *	the easy (scalar or error) case