citmods.c

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

{
    return makeexpr_bicall_3("sprintf", ex->val.type,
                             ex->args[0],
                             makeexpr_string("%c"),
                             ex->args[1]);
}



Static Expr *func_strreadint(ex)
Expr *ex;
{
    return makeexpr_bicall_3("strtol", tp_integer,
                             grabarg(ex, 0), 
                             makeexpr_nil(),
                             makeexpr_long(0));
}



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



Static Stmt *proc_strappendc(ex)
Expr *ex;
{
    Expr *ex2;

    ex2 = makeexpr_hat(ex->args[0], 0);
    return makestmt_assign(ex2, makeexpr_concat(copyexpr(ex2), ex->args[1], 0));
}



/* Check if a string begins with a given prefix; this is easy if the
 * prefix is known at compile-time.
 */

Static Expr *func_strbegins(ex)
Expr *ex;
{
    Expr *ex1, *ex2;

    ex1 = ex->args[0];
    ex2 = ex->args[1];
    if (ex2->kind == EK_CONST) {
        if (ex2->val.i == 1) {
            return makeexpr_rel(EK_EQ,
                                makeexpr_hat(ex1, 0),
                                makeexpr_char(ex2->val.s[0]));
        } else {
            return makeexpr_rel(EK_EQ,
                                makeexpr_bicall_3("strncmp", tp_int,
                                                  ex1,
                                                  ex2,
                                                  makeexpr_arglong(makeexpr_long(ex2->val.i), (size_t_long != 0))),
                                makeexpr_long(0));
        }
    }
    return ex;
}



Static Expr *func_strcontains(ex)
Expr *ex;
{
    return makeexpr_rel(EK_NE,
                        makeexpr_bicall_2("strpbrk", tp_strptr,
                                          ex->args[0],
                                          ex->args[1]),
                        makeexpr_nil());
}



/* Extract a substring of a string.  If arguments are out-of-range, extract
 * an empty or shorter substring.  Here, the length=infinity and constant
 * starting index cases are handled specially.
 */

Static Expr *func_strsub(ex)
Expr *ex;
{
    if (isliteralconst(ex->args[3], NULL) == 2 &&
        ex->args[3]->val.i >= stringceiling) {
        return makeexpr_bicall_3("sprintf", ex->val.type,
                                 ex->args[0],
                                 makeexpr_string("%s"),
                                 bumpstring(ex->args[1],
                                            makeexpr_unlongcast(ex->args[2]), 1));
    }
    if (checkconst(ex->args[2], 1)) {
        return makeexpr_addr(makeexpr_substring(ex->args[0], ex->args[1], 
                                                ex->args[2], ex->args[3]));
    }
    ex->args[2] = makeexpr_arglong(ex->args[2], 0);
    ex->args[3] = makeexpr_arglong(ex->args[3], 0);
    return ex;
}



Static Expr *func_strpart(ex)
Expr *ex;
{
    return func_strsub(ex);     /* all the special cases match */
}



Static Expr *func_strequal(ex)
Expr *ex;
{
    if (!*strcicmpname)
        return ex;
    return makeexpr_rel(EK_EQ, 
                        makeexpr_bicall_2(strcicmpname, tp_int,
                                          ex->args[0], ex->args[1]),
                        makeexpr_long(0));
}



Static Expr *func_strcmp(ex)
Expr *ex;
{
    return makeexpr_bicall_2("strcmp", tp_int, ex->args[0], ex->args[1]);
}



Static Expr *func_strljust(ex)
Expr *ex;
{
    return makeexpr_bicall_4("sprintf", ex->val.type,
                             ex->args[0],
                             makeexpr_string("%-*s"),
                             makeexpr_longcast(ex->args[2], 0),
                             ex->args[1]);
}



Static Expr *func_strrjust(ex)
Expr *ex;
{
    return makeexpr_bicall_4("sprintf", ex->val.type,
                             ex->args[0],
                             makeexpr_string("%*s"),
                             makeexpr_longcast(ex->args[2], 0),
                             ex->args[1]);
}




/* The procedure strnew(p,s) is converted into an assignment p = strdup(s). */

Static Stmt *proc_strnew(ex)
Expr *ex;
{
    return makestmt_assign(makeexpr_hat(ex->args[0], 0),
                           makeexpr_bicall_1("strdup", ex->args[1]->val.type,
                                             ex->args[1]));
}



/* These procedures are also changed to functions returning a result. */

Static Stmt *proc_strlist_add(ex)
Expr *ex;
{
    return makestmt_assign(makeexpr_hat(ex->args[1], 0),
                           makeexpr_bicall_2("strlist_add", ex->args[0]->val.type->basetype,
                                             ex->args[0],
                                             ex->args[2]));
}



Static Stmt *proc_strlist_append(ex)
Expr *ex;
{
    return makestmt_assign(makeexpr_hat(ex->args[1], 0),
                           makeexpr_bicall_2("strlist_append", ex->args[0]->val.type->basetype,
                                             ex->args[0],
                                             ex->args[2]));
}



Static Stmt *proc_strlist_insert(ex)
Expr *ex;
{
    return makestmt_assign(makeexpr_hat(ex->args[1], 0),
                           makeexpr_bicall_2("strlist_insert", ex->args[0]->val.type->basetype,
                                             ex->args[0],
                                             ex->args[2]));
}









/* NEWCI functions */


Static Stmt *proc_fixfname(ex)
Expr *ex;
{
    if (ex->args[1]->kind == EK_CONST)
	lwc(ex->args[1]->val.s);    /* Unix uses lower-case suffixes */
    return makestmt_call(ex);
}


Static Stmt *proc_forcefname(ex)
Expr *ex;
{
    return proc_fixfname(ex);
}


/* In Pascal these were variables of type pointer-to-text; we translate
 * them as, e.g., &stdin.  Note that even though &stdin is not legal in
 * many systems, in the common usage of writeln(stdin^) the & will
 * cancel out in a later stage of the translation.
 */

Static Expr *func_stdin()
{
    return makeexpr_addr(makeexpr_var(mp_input));
}


Static Expr *func_stdout()
{
    return makeexpr_addr(makeexpr_var(mp_output));
}


Static Expr *func_stderr()
{
    return makeexpr_addr(makeexpr_var(mp_stderr));
}








/* MYLIB functions */


Static Stmt *proc_m_color(ex)
Expr *ex;
{
    int i;
    long val;

    if (ex->kind == EK_PLUS) {
        for (i = 0; i < ex->nargs; i++) {
            if (isconstexpr(ex->args[i], &val)) {
                if (val > 0 && (val & 15) == 0) {
                    note("M_COLOR called with suspicious argument [508]");
                }
            }
        }
    } else if (ex->kind == EK_CONST) {
        if (ex->val.i >= 16 && ex->val.i < 255) {    /* accept true colors and m_trans */
            note("M_COLOR called with suspicious argument [508]");
        }
    }
    return makestmt_call(ex);
}







void citmods(name, defn)
char *name;
int defn;
{
    if (!strcmp(name, "NEWASM")) {
        makestandardproc("na_fillbyte", proc_na_fillbyte);
        makestandardproc("na_fill", proc_na_fill);
        makestandardproc("na_fillp", proc_na_fill);
        makestandardproc("na_move", proc_na_move);
        makestandardproc("na_movep", proc_na_move);
        makestandardproc("na_exch", proc_na_exch);
        makestandardproc("na_exchp", proc_na_exch);
        makestandardfunc("na_comp", func_na_comp);
        makestandardfunc("na_compp", func_na_comp);
        makestandardfunc("na_scaneq", func_na_scaneq);
        makestandardfunc("na_scaneqp", func_na_scaneq);
        makestandardfunc("na_scanne", func_na_scanne);
        makestandardfunc("na_scannep", func_na_scanne);
        makestandardproc("na_new", proc_na_new);
        makestandardproc("na_dispose", proc_na_dispose);
        makestandardproc("na_alloc", proc_na_alloc);
        makestandardproc("na_outeralloc", proc_na_outeralloc);
        makestandardproc("na_free", proc_na_free);
        makestandardfunc("na_memavail", func_na_memavail);
        makestandardfunc("na_and", func_na_and);
        makestandardfunc("na_bic", func_na_bic);
        makestandardfunc("na_or", func_na_or);
        makestandardfunc("na_xor", func_na_xor);
        makestandardfunc("na_not", func_na_not);
        makestandardfunc("na_mask", func_na_mask);
        makestandardfunc("na_test", func_na_test);
        makestandardproc("na_set", proc_na_set);
        makestandardproc("na_clear", proc_na_clear);
        makestandardfunc("na_po2", func_na_po2);
        makestandardfunc("na_hibits", func_na_hibits);
        makestandardfunc("na_lobits", func_na_lobits);
        makestandardfunc("na_asl", func_na_asl);
        makestandardfunc("na_lsl", func_na_lsl);
        makestandardproc("na_bfand", proc_na_bfand);
        makestandardproc("na_bfbic", proc_na_bfbic);
        makestandardproc("na_bfor", proc_na_bfor);
        makestandardproc("na_bfxor", proc_na_bfxor);
        makestandardfunc("imin", func_imin);
        makestandardfunc("imax", func_imax);
        makestandardfunc("na_add", func_na_add);
        makestandardfunc("na_sub", func_na_sub);
        makestandardproc("return", proc_return);
        makestandardfunc("charupper", func_charupper);
        makestandardfunc("charlower", func_charlower);
        makestandardfunc("strint", func_strint);
        makestandardfunc("strint2", func_strint2);
        makestandardfunc("strhex", func_strhex);
        makestandardfunc("strreal", func_strreal);
        makestandardfunc("strchar", func_strchar);
        makestandardfunc("strreadint", func_strreadint);
        makestandardfunc("strreadreal", func_strreadreal);
        makestandardproc("strappendc", proc_strappendc);
        makestandardfunc("strbegins", func_strbegins);
        makestandardfunc("strcontains", func_strcontains);
        makestandardfunc("strsub", func_strsub);
        makestandardfunc("strpart", func_strpart);
        makestandardfunc("strequal", func_strequal);
        makestandardfunc("strcmp", func_strcmp);
        makestandardfunc("strljust", func_strljust);
        makestandardfunc("strrjust", func_strrjust);
        makestandardproc("strnew", proc_strnew);
        makestandardproc("strlist_add", proc_strlist_add);
        makestandardproc("strlist_append", proc_strlist_append);
        makestandardproc("strlist_insert", proc_strlist_insert);
    } else if (!strcmp(name, "NEWCI")) {
	makestandardproc("fixfname", proc_fixfname);
	makestandardproc("forcefname", proc_forcefname);
        makestandardfunc("stdin", func_stdin);
        makestandardfunc("stdout", func_stdout);
        makestandardfunc("stderr", func_stderr);
    } else if (!strcmp(name, "MYLIB")) {
        makestandardproc("m_color", proc_m_color);
    }
}




/* End. */