expr.c

把pascal程序转成C语言程序 把pascal程序转成C语言程序

    if (i == 0)
	return realzero(s);
    if (*s == '-') {
	s++;
	i = -i;
    }
    if (i < 0 || i > 9) return 0;   /* we don't care about large values here */
    while (*s == '0') s++;
    if (*s++ != i + '0') return 0;
    if (*s == '.')
	while (*++s == '0') ;
    return (!isdigit(*s) && toupper(*s) != 'E');
}


int checkconst(ex, val)
Expr *ex;
long val;
{
    Meaning *mp;
    Value exval;

    if (!ex)
        return 0;
    if (ex->kind == EK_CAST || ex->kind == EK_ACTCAST)
        ex = ex->args[0];
    if (ex->kind == EK_CONST || ex->kind == EK_LONGCONST)
        exval = ex->val;
    else if (ex->kind == EK_VAR &&
             (mp = (Meaning *)ex->val.i)->kind == MK_CONST &&
	     mp->val.type &&
             foldconsts != 0)
        exval = mp->val;
    else
        return 0;
    switch (exval.type->kind) {

        case TK_BOOLEAN:
        case TK_INTEGER:
        case TK_CHAR:
        case TK_ENUM:
        case TK_SUBR:
        case TK_SMALLSET:
        case TK_SMALLARRAY:
            return exval.i == val;

        case TK_POINTER:
        case TK_STRING:
            return (val == 0 && exval.i == 0);

        case TK_REAL:
            return realint(exval.s, val);

	default:
	    return 0;
    }
}



int isliteralconst(ex, valp)
Expr *ex;
Value *valp;
{
    Meaning *mp;

    if (ex) {
        switch (ex->kind) {

            case EK_CONST:
            case EK_LONGCONST:
                if (valp)
                    *valp = ex->val;
                return 2;

            case EK_VAR:
                mp = (Meaning *)ex->val.i;
                if (mp->kind == MK_CONST) {
                    if (valp) {
                        if (foldconsts == 0)
                            valp->type = NULL;
                        else
                            *valp = mp->val;
                    }
                    return 1;
                }
                break;

	    default:
		break;
        }
    }
    if (valp)
        valp->type = NULL;
    return 0;
}



int isconstexpr(ex, valp)
Expr *ex;
long *valp;
{
    Value exval;

    if (debug>2) { fprintf(outf,"isconstexpr("); dumpexpr(ex); fprintf(outf,")\n"); }
    exval = eval_expr(ex);
    if (exval.type) {
        if (valp)
            *valp = exval.i;
        return 1;
    } else
        return 0;
}



int isconstantexpr(ex)
Expr *ex;
{
    Meaning *mp;
    int i;

    switch (ex->kind) {

        case EK_CONST:
        case EK_LONGCONST:
        case EK_SIZEOF:
            return 1;

        case EK_ADDR:
            if (ex->args[0]->kind == EK_VAR) {
                mp = (Meaning *)ex->args[0]->val.i;
                return (!mp->ctx || mp->ctx->kind == MK_MODULE);
            }
            return 0;

        case EK_VAR:
            mp = (Meaning *)ex->val.i;
            return (mp->kind == MK_CONST);

        case EK_BICALL:
        case EK_FUNCTION:
            if (!deterministic_func(ex))
                return 0;

        /* fall through */
        case EK_EQ:
        case EK_NE:
        case EK_LT:
        case EK_GT:
        case EK_LE:
        case EK_GE:
        case EK_PLUS:
        case EK_NEG:
        case EK_TIMES:
        case EK_DIVIDE:
        case EK_DIV:
        case EK_MOD:
        case EK_AND:
        case EK_OR:
        case EK_NOT:
        case EK_BAND:
        case EK_BOR:
        case EK_BXOR:
        case EK_BNOT:
        case EK_LSH:
        case EK_RSH:
        case EK_CAST:
        case EK_ACTCAST:
        case EK_COND:
            for (i = 0; i < ex->nargs; i++) {
                if (!isconstantexpr(ex->args[i]))
                    return 0;
            }
            return 1;

        case EK_COMMA:
            return isconstantexpr(ex->args[ex->nargs-1]);

	default:
	    return 0;
    }
}





Static Expr *docast(a, type)
Expr *a;
Type *type;
{
    Value val;
    Meaning *mp;
    int i;
    Expr *ex;

    if (a->val.type->kind == TK_SMALLSET && type->kind == TK_SET) {
        mp = makestmttempvar(type, name_SET);
        return makeexpr_bicall_2(setexpandname, type,
                                 makeexpr_var(mp),
                                 makeexpr_arglong(a, 1));
    } else if (a->val.type->kind == TK_SET && type->kind == TK_SMALLSET) {
        return packset(a, type);
    }
    switch (a->kind) {

        case EK_VAR:
            mp = (Meaning *) a->val.i;
            if (mp->kind == MK_CONST) {
                if (mp->val.type && mp->val.type->kind == TK_STRING &&
		    type->kind == TK_CHAR) {
                    val = value_cast(mp->val, type);
                    a->kind = EK_CONST;
                    a->val = val;
                    return a;
                }
            }
            break;

        case EK_CONST:
        case EK_LONGCONST:
            val = value_cast(a->val, type);
            if (val.type) {
                a->val = val;
                return a;
            }
            break;

        case EK_PLUS:
        case EK_NEG:
        case EK_TIMES:
            if (type->kind == TK_REAL) {
                for (i = 0; i < a->nargs; i++) {
                    ex = docast(a->args[i], type);
                    if (ex) {
                        a->args[i] = ex;
                        a->val.type = type;
                        return a;
                    }
                }
            }
            break;

	default:
	    break;
    }
    return NULL;
}



/* Make an "active" cast, i.e., one that performs an explicit operation */
Expr *makeexpr_actcast(a, type)
Expr *a;
Type *type;
{
    if (debug>2) { fprintf(outf,"makeexpr_actcast("); dumpexpr(a); fprintf(outf,", "); dumptypename(type, 1); fprintf(outf,")\n"); }

    if (similartypes(a->val.type, type)) {
        a->val.type = type;
        return a;
    }
    return makeexpr_un(EK_ACTCAST, type, a);
}



Expr *makeexpr_cast(a, type)
Expr *a;
Type *type;
{
    Expr *ex;

    if (debug>2) { fprintf(outf,"makeexpr_cast("); dumpexpr(a); fprintf(outf,", "); dumptypename(type, 1); fprintf(outf,")\n"); }
    if (a->val.type == type)
        return a;
    ex = docast(a, type);
    if (ex)
        return ex;
    if (a->kind == EK_CAST &&
        a->args[0]->val.type->kind == TK_POINTER &&
        similartypes(type, a->args[0]->val.type)) {
        a = grabarg(a, 0);
        a->val.type = type;
        return a;
    }
    if ((a->kind == EK_CAST &&
         ((a->val.type->kind == TK_POINTER && type->kind == TK_POINTER) ||
          (ord_type(a->val.type)->kind == TK_INTEGER && ord_type(type)->kind == TK_INTEGER))) ||
        similartypes(type, a->val.type)) {
        a->val.type = type;
        return a;
    }
    return makeexpr_un(EK_CAST, type, a);
}



Expr *gentle_cast(a, type)
Expr *a;
Type *type;
{
    Expr *ex;
    Type *btype;
    long smin, smax;
    Value val;
    char c;

    if (debug>2) { fprintf(outf,"gentle_cast("); dumpexpr(a); fprintf(outf,", "); dumptypename(type, 1); fprintf(outf,")\n"); }
    if (!type) {
	intwarning("gentle_cast", "type == NULL");
	return a;
    }
    if (a->val.type->kind == TK_POINTER && type->kind == TK_POINTER) {
        if (voidstar && (type == tp_anyptr || a->val.type == tp_anyptr)) {
            if (type == tp_anyptr && a->kind == EK_CAST &&
                a->args[0]->val.type->kind == TK_POINTER)
                return a->args[0];    /* remove explicit cast since casting implicitly */
            return a;                 /* casting to/from "void *" */
        }
        return makeexpr_cast(a, type);
    }
    if (type->kind == TK_STRING)
        return makeexpr_stringify(a);
    if (type->kind == TK_ARRAY &&
	(a->val.type->kind == TK_STRING ||
	 a->val.type->kind == TK_CHAR) &&
        isliteralconst(a, &val) && val.type &&
	ord_range(type->indextype, &smin, &smax)) {
	smax = smax - smin + 1;
	if (a->val.type->kind == TK_CHAR) {
	    val.s = &c;
	    c = val.i;
	    val.i = 1;
	}
	if (val.i > smax) {
	    warning("Too many characters for packed array of char [162]");
	} else if (val.i < smax || a->val.type->kind == TK_CHAR) {
	    ex = makeexpr_lstring(val.s, smax);
	    while (smax > val.i)
		ex->val.s[--smax] = ' ';
	    freeexpr(a);
	    return ex;
	}
    }
    btype = (type->kind == TK_SUBR) ? type->basetype : type;
    if ((a->kind == EK_CAST || a->kind == EK_ACTCAST) &&
        btype->kind == TK_INTEGER &&
        ord_type(a->val.type)->kind == TK_INTEGER)
        return makeexpr_longcast(a, long_type(type));
    if (a->val.type == btype)
        return a;
    ex = docast(a, btype);
    if (ex)
        return ex;
    if (btype->kind == TK_CHAR && a->val.type->kind == TK_STRING)
        return makeexpr_hat(a, 0);
    return a;
}



Expr *makeexpr_charcast(ex)
Expr *ex;
{
    Meaning *mp;

    if (ex->kind == EK_CONST && ex->val.type->kind == TK_STRING &&
        ex->val.i == 1) {
        ex->val.type = tp_char;
        ex->val.i = ex->val.s[0] & 0xff;
        ex->val.s = NULL;
    }
    if (ex->kind == EK_VAR &&
	(mp = (Meaning *)ex->val.i)->kind == MK_CONST &&
	mp->val.type &&
	mp->val.type->kind == TK_STRING &&
	mp->val.i == 1) {
      ex->kind = EK_CONST;
      ex->val.type = tp_char;
      ex->val.i = mp->val.s[0] & 0xff;
      ex->val.s = NULL;
    }
    return ex;
}



Expr *makeexpr_stringcast(ex)
Expr *ex;
{
    char ch;

    if (ex->kind == EK_CONST && ord_type(ex->val.type)->kind == TK_CHAR) {
        ch = ex->val.i;
        freeexpr(ex);
        ex = makeexpr_lstring(&ch, 1);
    }
    return ex;
}





/* 0/1 = force to int/long, 2/3 = check if int/long */

Static Expr *dolongcast(a, tolong)
Expr *a;
int tolong;
{
    Meaning *mp;
    Expr *ex;
    Type *type;
    int i;

    switch (a->kind) {

        case EK_DOT:
            if (!a->val.i) {
                if (long_type(a->val.type) == (tolong&1))
                    return a;
                break;
            }

        /* fall through */
        case EK_VAR:
            mp = (Meaning *)a->val.i;
            if (mp->kind == MK_FIELD && mp->val.i) {
                if (mp->val.i <= ((sizeof_int > 0) ? sizeof_int : 16) &&
                    !(tolong&1))
                    return a;
            } else if (mp->kind == MK_VAR ||
                       mp->kind == MK_VARREF ||
                       mp->kind == MK_PARAM ||
                       mp->kind == MK_VARPARAM ||
                       mp->kind == MK_FIELD) {
                if (long_type(mp->type) == (tolong&1))
                    return a;
            }
            break;

        case EK_FUNCTION:
            mp = (Meaning *)a->val.i;
            if (long_type(mp->type->basetype) == (tolong&1))
                return a;
            break;

        case EK_BICALL:
            if (!strcmp(a->val.s, signextname) && *signextname) {
                i = 0;
                goto unary;
            }
	    if (!strcmp(a->val.s, "strlen"))
		goto size_t_case;
            /* fall through */

        case EK_HAT:      /* get true type from a->val.type */
        case EK_INDEX:
        case EK_SPCALL:
        case EK_NAME:
            if (long_type(a->val.type) == (tolong&1))
                return a;
            break;

        case EK_ASSIGN:   /* destination determines type, */
        case EK_POSTINC:  /*  but must not be changed */
        case EK_POSTDEC:
            return dolongcast(a->args[0], tolong|2);

        case EK_CAST:
            if (ord_type(a->val.type)->kind == TK_INTEGER &&
                 long_type(a->val.type) == (tolong&1))
                return a;
            if (tolong == 0) {
                a->val.type = tp_int;
                return a;
            } else if (tolong == 1) {
                a->val.type = tp_integer;
                return a;
            }
            break;

        case EK_ACTCAST:
            if (ord_type(a->val.type)->kind == TK_INTEGER &&
                 long_type(a->val.type) == (tolong&1))
                return a;
            break;

        case EK_CONST:
            type = ord_type(a->val.type);
            if (type->kind == TK_INTEGER || type->kind == TK_SMALLSET) {
                if (tolong == 1)
                    a->kind = EK_LONGCONST;
                if (tolong != 3)
                    return a;
            }
            break;

        case EK_LONGCONST:
            if (tolong == 0) {
                if (a->val.i >= -32767 && a->val.i <= 32767)
                    a->kind = EK_CONST;
                else
                    return NULL;
            }
            if (tolong != 2)
                return a;
            break;

        case EK_SIZEOF:
	size_t_case:
            if (size_t_long > 0 && tolong&1)
                return a;
            if (size_t_long == 0 && !(tolong&1))
                return a;
            break;

        case EK_PLUS:     /* usual arithmetic conversions apply */
        case EK_TIMES:
        case EK_DIV:
        case EK_MOD:
        case EK_BAND:
        case EK_BOR:
        case EK_BXOR:
        case EK_COND:
            i = (a->kind == EK_COND) ? 1 : 0;
            if (tolong&1) {
                for (; i < a->nargs; i++) {
                    ex = dolongcast(a->args[i], tolong);
                    if (ex) {
                        a->args[i] = ex;
                        return a;
                    }
                }
            } else {
                for (; i < a->nargs; i++) {
                    if (!dolongcast(a->args[i], tolong))
                        return NULL;
                }
                return a;
            }
            break;

        case EK_BNOT:     /* single argument defines result type */
        case EK_NEG:
        case EK_LSH:
        case EK_RSH:
        case EK_COMMA:
            i = (a->kind == EK_COMMA) ? a->nargs-1 : 0;
unary:
            if (tolong&1) {
                ex = dolongcast(a->args[i], tolong);
                if (ex) {
                    a->args[i] = ex;