funcs.c

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

int scale;
{
    Expr *lex, *dex, *vex;
    Meaning *tvar;
    Type *tp;
    long smin, smax;
    int bits;

    if (!ex) {
	if (!skipopenparen())
	    return NULL;
	ex = p_expr(tp_integer);
    }
    tp = true_type(ex);
    if (ord_range(tp, &smin, &smax))
	bits = typebits(smin, smax);
    else
	bits = 32;
    if (curtok == TOK_COMMA) {
	gettok();
	if (curtok != TOK_COMMA)
	    lex = makeexpr_arglong(p_expr(tp_integer), 0);
	else
	    lex = NULL;
    } else
	lex = NULL;
    if (!lex) {
	if (!scale)
	    lex = makeexpr_long(11);
	else
	    lex = makeexpr_long((bits+scale-1) / scale + 1);
    }
    if (curtok == TOK_COMMA) {
	gettok();
	dex = makeexpr_arglong(p_expr(tp_integer), 0);
    } else {
	if (!scale)
	    dex = makeexpr_long(10);
	else
	    dex = makeexpr_long((bits+scale-1) / scale);
    }
    if (lex->kind == EK_CONST && dex->kind == EK_CONST &&
	lex->val.i < dex->val.i)
	lex = NULL;
    skipcloseparen();
    tvar = makestmttempvar(tp_str255, name_STRING);
    vex = makeexpr_var(tvar);
    ex = makeexpr_forcelongness(ex);
    if (exprlongness(ex) > 0)
	fmt = format_s("l%s", fmt);
    if (checkconst(lex, 0) || checkconst(lex, 1))
	lex = NULL;
    if (checkconst(dex, 0) || checkconst(dex, 1))
	dex = NULL;
    if (lex) {
	if (dex)
	    ex = makeexpr_bicall_5("sprintf", tp_str255, vex,
				   makeexpr_string(format_s("%%*.*%s", fmt)),
				   lex, dex, ex);
	else
	    ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
				   makeexpr_string(format_s("%%*%s", fmt)),
				   lex, ex);
    } else {
	if (dex)
	    ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
				   makeexpr_string(format_s("%%.*%s", fmt)),
				   dex, ex);
	else
	    ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
				   makeexpr_string(format_s("%%%s", fmt)),
				   ex);
    }
    return ex;
}




Static Expr *func_hex()
{
    Expr *ex;
    char *cp;

    if (!skipopenparen())
	return NULL;
    ex = makeexpr_stringcast(p_expr(tp_integer));
    if ((ex->val.type->kind == TK_STRING ||
	 ex->val.type == tp_strptr) &&
	curtok != TOK_COMMA) {
	skipcloseparen();
	if (ex->kind == EK_CONST) {    /* HP Pascal */
	    cp = getstring(ex);
	    ex = makeexpr_long(my_strtol(cp, NULL, 16));
	    insertarg(&ex, 0, makeexpr_name("%#lx", tp_integer));
	    return ex;
	} else {
	    return makeexpr_bicall_3("strtol", tp_integer, 
				     ex, makeexpr_nil(), makeexpr_long(16));
	}
    } else {    /* VAX Pascal */
	return handle_vax_hex(ex, "x", 4);
    }
}



Static Expr *func_hi()
{
    Expr *ex;

    ex = force_unsigned(p_parexpr(tp_integer));
    return makeexpr_bin(EK_RSH, tp_ubyte,
                        ex, makeexpr_long(8));
}



Static Expr *func_high()
{
    Expr *ex;
    Type *type;

    ex = p_parexpr(tp_integer);
    type = ex->val.type;
    if (type->kind == TK_POINTER)
	type = type->basetype;
    if (type->kind == TK_ARRAY ||
	type->kind == TK_SMALLARRAY) {
	ex = makeexpr_minus(copyexpr(type->indextype->smax),
			    copyexpr(type->indextype->smin));
    } else {
	warning("HIGH requires an array name parameter [210]");
	ex = makeexpr_bicall_1("HIGH", tp_int, ex);
    }
    return ex;
}



Static Expr *func_hiword()
{
    Expr *ex;

    ex = force_unsigned(p_parexpr(tp_unsigned));
    return makeexpr_bin(EK_RSH, tp_unsigned,
                        ex, makeexpr_long(16));
}



Static Stmt *proc_inc()
{
    Expr *vex, *ex;

    if (!skipopenparen())
	return NULL;
    vex = p_expr(NULL);
    if (curtok == TOK_COMMA) {
        gettok();
        ex = p_expr(tp_integer);
    } else
        ex = makeexpr_long(1);
    skipcloseparen();
    return makestmt_assign(vex, makeexpr_plus(copyexpr(vex), ex));
}



Static Stmt *proc_incl()
{
    Expr *vex, *ex;

    if (!skipopenparen())
	return NULL;
    vex = p_expr(NULL);
    if (!skipcomma())
	return NULL;
    ex = p_expr(vex->val.type->indextype);
    skipcloseparen();
    if (vex->val.type->kind == TK_SMALLSET)
	return makestmt_assign(vex, makeexpr_bin(EK_BOR, vex->val.type,
						 copyexpr(vex),
						 makeexpr_bin(EK_LSH, vex->val.type,
							      makeexpr_longcast(makeexpr_long(1), 1),
							      ex)));
    else
	return makestmt_call(makeexpr_bicall_2(setaddname, tp_void, vex,
					       makeexpr_arglong(enum_to_int(ex), 0)));
}



Static Stmt *proc_insert(ex)
Expr *ex;
{
    return makestmt_call(makeexpr_bicall_3(strinsertname, tp_void,
                                           ex->args[0], 
                                           ex->args[1],
                                           makeexpr_arglong(ex->args[2], 0)));
}



Static Expr *func_int()
{
    Expr *ex;
    Meaning *tvar;

    ex = p_parexpr(tp_integer);
    if (ex->val.type->kind == TK_REAL) {    /* Turbo Pascal INT */
	tvar = makestmttempvar(tp_longreal, name_TEMP);
	return makeexpr_comma(makeexpr_bicall_2("modf", tp_longreal,
						grabarg(ex, 0),
						makeexpr_addr(makeexpr_var(tvar))),
			      makeexpr_var(tvar));
    } else {     /* VAX Pascal INT */
	return makeexpr_ord(ex);
    }
}


Static Expr *func_uint()
{
    Expr *ex;

    ex = p_parexpr(tp_integer);
    return makeexpr_cast(ex, tp_unsigned);
}



Static Stmt *proc_leave()
{
    return makestmt(SK_BREAK);
}



Static Expr *func_lint()
{
    Expr *ex;

    ex = p_parexpr(tp_integer);
    return pascaltypecast(tp_integer, ex);
}



Static Expr *func_lo()
{
    Expr *ex;

    ex = gentle_cast(p_parexpr(tp_integer), tp_ushort);
    return makeexpr_bin(EK_BAND, tp_ubyte,
                        ex, makeexpr_long(255));
}


Static Expr *func_loophole()
{
    Type *type;
    Expr *ex;

    if (!skipopenparen())
	return NULL;
    type = p_type(NULL);
    if (!skipcomma())
	return NULL;
    ex = p_expr(tp_integer);
    skipcloseparen();
    return pascaltypecast(type, ex);
}



Static Expr *func_lower()
{
    Expr *ex;
    Value val;

    if (!skipopenparen())
	return NULL;
    ex = p_expr(tp_integer);
    if (curtok == TOK_COMMA) {
	gettok();
	val = p_constant(tp_integer);
	if (!val.type || val.i != 1)
	    note("LOWER(v,n) not supported for n>1 [190]");
    }
    skipcloseparen();
    return copyexpr(ex->val.type->indextype->smin);
}



Static Expr *func_loword()
{
    Expr *ex;

    ex = p_parexpr(tp_integer);
    return makeexpr_bin(EK_BAND, tp_ushort,
                        ex, makeexpr_long(65535));
}



Static Expr *func_ln(ex)
Expr *ex;
{
    return makeexpr_bicall_1("log", tp_longreal, grabarg(ex, 0));
}



Static Expr *func_log(ex)
Expr *ex;
{
    return makeexpr_bicall_1("log10", tp_longreal, grabarg(ex, 0));
}



Static Expr *func_max()
{
    Type *tp;
    Expr *ex, *ex2;

    if (!skipopenparen())
	return NULL;
    if (curtok == TOK_IDENT && curtokmeaning &&
	curtokmeaning->kind == MK_TYPE) {
	tp = curtokmeaning->type;
	gettok();
	skipcloseparen();
	return copyexpr(tp->smax);
    }
    ex = p_expr(tp_integer);
    while (curtok == TOK_COMMA) {
	gettok();
	ex2 = p_expr(ex->val.type);
	if (ex->val.type->kind == TK_REAL) {
	    tp = ex->val.type;
	    if (ex2->val.type->kind != TK_REAL)
		ex2 = makeexpr_cast(ex2, tp);
	} else {
	    tp = ex2->val.type;
	    if (ex->val.type->kind != TK_REAL)
		ex = makeexpr_cast(ex, tp);
	}
	ex = makeexpr_bicall_2((tp->kind == TK_REAL) ? "P_rmax" : "P_imax",
			       tp, ex, ex2);
    }				
    skipcloseparen();
    return ex;
}



Static Expr *func_maxavail(ex)
Expr *ex;
{
    freeexpr(ex);
    return makeexpr_bicall_0("maxavail", tp_integer);
}



Static Expr *func_maxpos()
{
    return file_iofunc(3, seek_base);
}



Static Expr *func_memavail(ex)
Expr *ex;
{
    freeexpr(ex);
    return makeexpr_bicall_0("memavail", tp_integer);
}



Static Expr *var_mem()
{
    Expr *ex, *ex2;

    if (!wneedtok(TOK_LBR))
	return makeexpr_name("MEM", tp_integer);
    ex = p_expr(tp_integer);
    if (curtok == TOK_COLON) {
	gettok();
	ex2 = p_expr(tp_integer);
	ex = makeexpr_bicall_2("MEM", tp_ubyte, ex, ex2);
    } else {
	ex = makeexpr_bicall_1("MEM", tp_ubyte, ex);
    }
    if (!wneedtok(TOK_RBR))
	skippasttotoken(TOK_RBR, TOK_SEMI);
    note("Reference to MEM [191]");
    return ex;
}



Static Expr *var_memw()
{
    Expr *ex, *ex2;

    if (!wneedtok(TOK_LBR))
	return makeexpr_name("MEMW", tp_integer);
    ex = p_expr(tp_integer);
    if (curtok == TOK_COLON) {
	gettok();
	ex2 = p_expr(tp_integer);
	ex = makeexpr_bicall_2("MEMW", tp_ushort, ex, ex2);
    } else {
	ex = makeexpr_bicall_1("MEMW", tp_ushort, ex);
    }
    if (!wneedtok(TOK_RBR))
	skippasttotoken(TOK_RBR, TOK_SEMI);
    note("Reference to MEMW [191]");
    return ex;
}



Static Expr *var_meml()
{
    Expr *ex, *ex2;

    if (!wneedtok(TOK_LBR))
	return makeexpr_name("MEML", tp_integer);
    ex = p_expr(tp_integer);
    if (curtok == TOK_COLON) {
	gettok();
	ex2 = p_expr(tp_integer);
	ex = makeexpr_bicall_2("MEML", tp_integer, ex, ex2);
    } else {
	ex = makeexpr_bicall_1("MEML", tp_integer, ex);
    }
    if (!wneedtok(TOK_RBR))
	skippasttotoken(TOK_RBR, TOK_SEMI);
    note("Reference to MEML [191]");
    return ex;
}



Static Expr *func_min()
{
    Type *tp;
    Expr *ex, *ex2;

    if (!skipopenparen())
	return NULL;
    if (curtok == TOK_IDENT && curtokmeaning &&
	curtokmeaning->kind == MK_TYPE) {
	tp = curtokmeaning->type;
	gettok();
	skipcloseparen();
	return copyexpr(tp->smin);
    }
    ex = p_expr(tp_integer);
    while (curtok == TOK_COMMA) {
	gettok();
	ex2 = p_expr(ex->val.type);
	if (ex->val.type->kind == TK_REAL) {
	    tp = ex->val.type;
	    if (ex2->val.type->kind != TK_REAL)
		ex2 = makeexpr_cast(ex2, tp);
	} else {
	    tp = ex2->val.type;
	    if (ex->val.type->kind != TK_REAL)
		ex = makeexpr_cast(ex, tp);
	}
	ex = makeexpr_bicall_2((tp->kind == TK_REAL) ? "P_rmin" : "P_imin",
			       tp, ex, ex2);
    }				
    skipcloseparen();
    return ex;
}



Static Stmt *proc_move(ex)
Expr *ex;
{
    ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);    /* source */
    ex->args[1] = gentle_cast(ex->args[1], tp_anyptr);    /* dest */
    ex->args[2] = convert_size(choosetype(argbasetype(ex->args[0]),
                                          argbasetype(ex->args[1])), ex->args[2], "MOVE");
    return makestmt_call(makeexpr_bicall_3("memmove", tp_void,
                                           ex->args[1],
                                           ex->args[0],
                                           makeexpr_arglong(ex->args[2], (size_t_long != 0))));
}



Static Stmt *proc_move_fast()
{
    Expr *ex, *ex2, *ex3, *ex4;

    if (!skipopenparen())
	return NULL;
    ex = p_expr(tp_integer);
    if (!skipcomma())
	return NULL;
    ex2 = p_expr(tp_integer);
    if (!skipcomma())
	return NULL;
    ord_range_expr(ex2->val.type->indextype, &ex4, NULL);
    ex2 = makeexpr_index(ex2, p_expr(tp_integer), copyexpr(ex4));
    if (!skipcomma())
	return NULL;
    ex3 = p_expr(tp_integer);
    if (!skipcomma())
	return NULL;
    ord_range_expr(ex3->val.type->indextype, &ex4, NULL);
    ex3 = makeexpr_index(ex3, p_expr(tp_integer), copyexpr(ex4));
    skipcloseparen();
    ex = convert_size(choosetype(argbasetype(ex2),
				 argbasetype(ex3)), ex, "MOVE_FAST");
    return makestmt_call(makeexpr_bicall_3("memmove", tp_void,
					   makeexpr_addr(ex3),
					   makeexpr_addr(ex2),
					   makeexpr_arglong(ex, (size_t_long != 0))));
}



Static Stmt *proc_new()
{
    Expr *ex;
    Stmt *sp, **spp;
    Type *type;

    if (!skipopenparen())
	return NULL;
    ex = p_expr(tp_anyptr);
    type = ex->val.type;
    if (type->kind == TK_POINTER)
	type = type->basetype;
    sp = makestmt_call(handle_new(ex));
    spp = &sp->next;
    if (type->kind == TK_RECORD)
	initfilevars(type->fbase, &spp, makeexpr_hat(ex, 0));
    else if (isfiletype(type, -1))
	sp = makestmt_seq(sp, makestm