citmods.c

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

/* "p2c", a Pascal to C translator.
   Copyright (C) 1989, 1990, 1991, 1992, 1993 Free Software Foundation.
   Author's address: [e-mail].

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation (any version).

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */



#define PROTO_CITMODS_C
#include "trans.h"



/* The following functions define special translations for several
 * HP Pascal modules developed locally at Caltech.  For non-Caltech
 * readers this file will serve mainly as a body of examples.
 *
 * The FuncMacro mechanism (introduced after this file was written)
 * provides a simpler method for cases where the function translates
 * into some fixed C equivalent.
 */




/* NEWASM functions */


/* na_fillbyte: equivalent to memset, though convert_size is used to
 * generalize the size a bit:  na_fillbyte(a, 0, 80) where a is an array
 * of integers (4 bytes in HP Pascal) will be translated to
 * memset(a, 0, 20 * sizeof(int)).
 */

Static Stmt *proc_na_fillbyte(ex)
Expr *ex;
{
    ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
    ex->args[2] = convert_size(argbasetype(ex->args[0]), ex->args[2], "NA_FILLBYTE");
    return makestmt_call(makeexpr_bicall_3("memset", tp_void,
                                           ex->args[0],
                                           makeexpr_arglong(ex->args[1], 0),
                                           makeexpr_arglong(ex->args[2], (size_t_long != 0))));
}



/* This function fills with a 32-bit pattern.  If all four bytes of the
 * pattern are equal, memset is used, otherwise the na_fill call is
 * left unchanged.
 */

Static Stmt *proc_na_fill(ex)
Expr *ex;
{
    unsigned long ul;
    Symbol *sym;

    ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
    ex->args[2] = convert_size(argbasetype(ex->args[0]), ex->args[2], "NA_FILL");
    if (!strcmp(((Meaning *)ex->val.i)->sym->name, "NA_FILLP")) {
        sym = findsymbol("NA_FILL");
        if (sym->mbase)
            ex->val.i = (long)sym->mbase;
    }
    if (isliteralconst(ex->args[1], NULL) != 2)
        return makestmt_call(ex);
    ul = ex->args[1]->val.i;
    if ((((ul >> 16) ^ ul) & 0xffff) ||    /* all four bytes must be the same */
        (((ul >> 8) ^ ul) & 0xff))
        return makestmt_call(ex);
    ex->args[1]->val.i &= 0xff;
    return makestmt_call(makeexpr_bicall_3("memset", tp_void,
                                           ex->args[0],
                                           makeexpr_arglong(ex->args[1], 0),
                                           makeexpr_arglong(ex->args[2], (size_t_long != 0))));
}



Static Stmt *proc_na_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], "NA_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))));
}



/* This just generalizes the size and leaves the function call alone,
 * except that na_exchp (a version using pointer args) is transformed
 * to na_exch (a version using VAR args, equivalent in C).
 */

Static Stmt *proc_na_exch(ex)
Expr *ex;
{
    Symbol *sym;

    ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
    ex->args[1] = gentle_cast(ex->args[1], tp_anyptr);
    ex->args[2] = convert_size(choosetype(argbasetype(ex->args[0]),
                                          argbasetype(ex->args[1])), ex->args[2], "NA_EXCH");
    if (!strcmp(((Meaning *)ex->val.i)->sym->name, "NA_EXCHP")) {
        sym = findsymbol("NA_EXCH");
        if (sym->mbase)
            ex->val.i = (long)sym->mbase;
    }
    return makestmt_call(ex);
}



Static Expr *func_na_comp(ex)
Expr *ex;
{
    ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
    ex->args[1] = gentle_cast(ex->args[1], tp_anyptr);
    ex->args[2] = convert_size(choosetype(argbasetype(ex->args[0]),
                                          argbasetype(ex->args[1])), ex->args[2], "NA_COMP");
    return makeexpr_bicall_3("memcmp", tp_int,
                             ex->args[0],
                             ex->args[1],
                             makeexpr_arglong(ex->args[2], (size_t_long != 0)));
}



Static Expr *func_na_scaneq(ex)
Expr *ex;
{
    Symbol *sym;

    ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
    ex->args[2] = convert_size(argbasetype(ex->args[0]), ex->args[2], "NA_SCANEQ");
    if (!strcmp(((Meaning *)ex->val.i)->sym->name, "NA_SCANEQP")) {
        sym = findsymbol("NA_SCANEQ");
        if (sym->mbase)
            ex->val.i = (long)sym->mbase;
    }
    return ex;
}



Static Expr *func_na_scanne(ex)
Expr *ex;
{
    Symbol *sym;

    ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
    ex->args[2] = convert_size(argbasetype(ex->args[0]), ex->args[2], "NA_SCANNE");
    if (!strcmp(((Meaning *)ex->val.i)->sym->name, "NA_SCANNEP")) {
        sym = findsymbol("NA_SCANNE");
        if (sym->mbase)
            ex->val.i = (long)sym->mbase;
    }
    return ex;
}



Static Stmt *proc_na_new(ex)
Expr *ex;
{
    Expr *vex, *ex2, *sz = NULL;
    Stmt *sp;

    vex = makeexpr_hat(eatcasts(ex->args[0]), 0);
    ex2 = ex->args[1];
    if (vex->val.type->kind == TK_POINTER)
        ex2 = convert_size(vex->val.type->basetype, ex2, "NA_NEW");
    if (alloczeronil)
        sz = copyexpr(ex2);
    ex2 = makeexpr_bicall_1(mallocname, tp_anyptr, ex2);
    sp = makestmt_assign(copyexpr(vex), ex2);
    if (malloccheck) {
        sp = makestmt_seq(sp, makestmt_if(makeexpr_rel(EK_EQ, copyexpr(vex), makeexpr_nil()),
                                          makestmt_call(makeexpr_bicall_1(name_ESCAPE, tp_int, 
                                                                          makeexpr_long(-2))),
                                          NULL));
    }
    if (sz && !isconstantexpr(sz)) {
        if (alloczeronil == 2)
            note("Called NA_NEW with variable argument [500]");
        sp = makestmt_if(makeexpr_rel(EK_NE, sz, makeexpr_long(0)),
                         sp,
                         makestmt_assign(vex, makeexpr_nil()));
    } else
        freeexpr(vex);
    return sp;
}



Static Stmt *proc_na_dispose(ex)
Expr *ex;
{
    Stmt *sp;
    Expr *vex;

    vex = makeexpr_hat(eatcasts(ex->args[0]), 0);
    sp = makestmt_call(makeexpr_bicall_1(freename, tp_void, copyexpr(vex)));
    if (alloczeronil) {
        sp = makestmt_if(makeexpr_rel(EK_NE, vex, makeexpr_nil()),
                         sp, NULL);
    } else
        freeexpr(vex);
    return sp;
}



/* These functions provide functionality similar to alloca; we just warn
 * about them here since alloca would not have been portable enough for
 * our purposes anyway.
 */

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

    note("Call to NA_ALLOC [501]");
    ex->args[0] = eatcasts(ex->args[0]);
    ex2 = ex->args[0];
    if (ex2->val.type->kind == TK_POINTER &&
	ex2->val.type->basetype->kind == TK_POINTER)
        ex->args[1] = convert_size(ex2->val.type->basetype->basetype,
				   ex->args[1], "NA_ALLOC");
    return makestmt_call(ex);
}



Static Stmt *proc_na_outeralloc(ex)
Expr *ex;
{
    note("Call to NA_OUTERALLOC [502]");
    return makestmt_call(ex);
}



Static Stmt *proc_na_free(ex)
Expr *ex;
{
    note("Call to NA_FREE [503]");
    return makestmt_call(ex);
}




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




/* A simple collection of bitwise operations. */

Static Expr *func_na_and(ex)
Expr *ex;
{
    Expr *ex0, *ex1;

    ex0 = makeexpr_unlongcast(ex->args[0]);
    ex1 = makeexpr_unlongcast(ex->args[1]);
    return makeexpr_bin(EK_BAND, tp_integer, ex0, ex1);
}



Static Expr *func_na_bic(ex)
Expr *ex;
{
    Expr *ex0, *ex1;

    ex0 = makeexpr_unlongcast(ex->args[0]);
    ex1 = makeexpr_unlongcast(ex->args[1]);
    return makeexpr_bin(EK_BAND, tp_integer, 
                        ex0,
                        makeexpr_un(EK_BNOT, ex1->val.type, ex1));
}



Static Expr *func_na_or(ex)
Expr *ex;
{
    Expr *ex0, *ex1;

    ex0 = makeexpr_unlongcast(ex->args[0]);
    ex1 = makeexpr_unlongcast(ex->args[1]);
    return makeexpr_bin(EK_BOR, tp_integer, ex0, ex1);
}



Static Expr *func_na_xor(ex)
Expr *ex;
{
    Expr *ex0, *ex1;

    ex0 = makeexpr_unlongcast(ex->args[0]);
    ex1 = makeexpr_unlongcast(ex->args[1]);
    return makeexpr_bin(EK_BXOR, tp_integer, ex0, ex1);
}



Static Expr *func_na_not(ex)
Expr *ex;
{
    ex = makeexpr_unlongcast(grabarg(ex, 0));
    return makeexpr_un(EK_BNOT, ex->val.type, ex);
}



Static Expr *func_na_mask(ex)
Expr *ex;
{
    Expr *ex0, *ex1;

    ex0 = makeexpr_unlongcast(ex->args[0]);
    ex1 = makeexpr_unlongcast(ex->args[1]);
    ex = makeexpr_bin(EK_BAND, tp_integer, ex0, ex1);
    return makeexpr_rel(EK_NE, ex, makeexpr_long(0));
}



Static int check0_31(ex)
Expr *ex;
{
    if (isliteralconst(ex, NULL) == 2)
        return (ex->val.i >= 0 && ex->val.i <= 31);
    else
        return (assumebits != 0);
}



/* This function is defined to test a bit of an integer, returning false
 * if the bit number is out of range.  It is only safe to use C bitwise
 * ops if we can prove the bit number is always in range, or if the
 * user has asked us to assume that it is.  Lacking flow analysis,
 * we settle for checking constants only.
 */

Static Expr *func_na_test(ex)
Expr *ex;
{
    Expr *ex1;
    int longness;

    if (!check0_31(ex->args[0]))
        return ex;
    ex1 = makeexpr_unlongcast(ex->args[1]);
    longness = (exprlongness(ex1) != 0);
    return makeexpr_rel(EK_NE,
                        makeexpr_bin(EK_BAND, tp_integer,