/* "p2c", a Pascal to C translator.
   Copyright (C) 1989, 1990, 1991, 1992, 1993 Free Software Foundation.
   Author's address: daveg@synaptics.com.

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,
                                     ex1,
                                     makeexpr_bin(EK_LSH, tp_integer,
                                                  makeexpr_longcast(makeexpr_long(1), longness),
                                                  makeexpr_unlongcast(ex->args[0]))),
                        makeexpr_long(0));
}



Static Stmt *proc_na_set(ex)
Expr *ex;
{
    Stmt *sp;
    Expr *vex;
    Meaning *tvar;

    if (!check0_31(ex->args[0]))
        return makestmt_call(ex);
    if (!nosideeffects(ex->args[1], 1)) {
        tvar = makestmttempvar(ex->args[1]->val.type, name_TEMP);
        sp = makestmt_assign(makeexpr_var(tvar), ex->args[1]);
        vex = makeexpr_hat(makeexpr_var(tvar), 0);
    } else {
        sp = NULL;
        vex = makeexpr_hat(ex->args[1], 0);
    }
    sp = makestmt_seq(sp,
                      makestmt_assign(vex,
                                      makeexpr_bin(EK_BOR, tp_integer,
                                                   copyexpr(vex),
                                                   makeexpr_bin(EK_LSH, tp_integer,
                                                                makeexpr_longcast(makeexpr_long(1), 1),
                                                                makeexpr_unlongcast(ex->args[0])))));
    return sp;
}



Static Stmt *proc_na_clear(ex)
Expr *ex;
{
    Stmt *sp;
    Expr *vex;
    Meaning *tvar;

    if (!check0_31(ex->args[0]))
        return makestmt_call(ex);
    if (!nosideeffects(ex->args[1], 1)) {
        tvar = makestmttempvar(ex->args[1]->val.type, name_TEMP);
        sp = makestmt_assign(makeexpr_var(tvar), ex->args[1]);
        vex = makeexpr_hat(makeexpr_var(tvar), 0);
    } else {
        sp = NULL;
        vex = makeexpr_hat(ex->args[1], 0);
    }
    sp = makestmt_seq(sp,
                      makestmt_assign(vex,
                                      makeexpr_bin(EK_BAND, tp_integer,
                                                   copyexpr(vex),
                                                   makeexpr_un(EK_BNOT, tp_integer,
                                                       makeexpr_bin(EK_LSH, tp_integer,
                                                                    makeexpr_longcast(makeexpr_long(1), 1),
                                                                    makeexpr_unlongcast(ex->args[0]))))));
    return sp;
}



Static Expr *func_na_po2(ex)
Expr *ex;
{
    if (!check0_31(ex->args[0]))
        return ex;
    return makeexpr_bin(EK_LSH, tp_integer,
                        makeexpr_longcast(makeexpr_long(1), 1),
                        makeexpr_unlongcast(grabarg(ex, 0)));
}



Static Expr *func_na_lobits(ex)
Expr *ex;
{
    if (!check0_31(ex->args[0]))
        return ex;
    return makeexpr_un(EK_BNOT, tp_integer,
                       makeexpr_bin(EK_LSH, tp_integer,
                                    makeexpr_longcast(makeexpr_long(-1), 1),
                                    makeexpr_unlongcast(grabarg(ex, 0))));
}



Static Expr *func_na_hibits(ex)
Expr *ex;
{
    if (!check0_31(ex->args[0]))
        return ex;
    return makeexpr_bin(EK_LSH, tp_integer,
                        makeexpr_longcast(makeexpr_long(-1), 1),
                        makeexpr_minus(makeexpr_long(32),
                                       makeexpr_unlongcast(grabarg(ex, 0))));
}



/* This function does an arithmetic shift left, or right for negative shift
 * count.  We translate into a C shift only if we are confident of the
 * sign of the shift count.
 */

Static Expr *func_na_asl(ex)
Expr *ex;
{
    Expr *ex2;

    ex2 = makeexpr_unlongcast(copyexpr(ex->args[0]));
    if (expr_is_neg(ex2)) {
        if (signedshift == 0 || signedshift == 2)
            return ex;
	if (possiblesigns(ex2) & 4) {
            if (assumesigns)
                note("Assuming count for NA_ASL is negative [504]");
            else
                return ex;
        }
        if (signedshift != 1)
            note("Assuming >> is an arithmetic shift [505]");
        return makeexpr_bin(EK_RSH, tp_integer,
			    grabarg(ex, 1), makeexpr_neg(ex2));
    } else {
	if (possiblesigns(ex2) & 1) {
            if (assumesigns)
                note("Assuming count for NA_ASL is positive [504]");
            else
                return ex;
        }
        return makeexpr_bin(EK_LSH, tp_integer, grabarg(ex, 1), ex2);
    }
}



Static Expr *func_na_lsl(ex)
Expr *ex;
{
    Expr *ex2;

    ex2 = makeexpr_unlongcast(copyexpr(ex->args[0]));
    if (expr_is_neg(ex2)) {
	if (possiblesigns(ex2) & 4) {
            if (assumesigns)
                note("Assuming count for NA_LSL is negative [506]");
            else
                return ex;
        }
        return makeexpr_bin(EK_RSH, tp_integer, 
                            force_unsigned(grabarg(ex, 1)),
			    makeexpr_neg(ex2));
    } else {
	if (possiblesigns(ex2) & 1) {
            if (assumesigns)
                note("Assuming count for NA_LSL is positive [506]");
            else
                return ex;
        }
        return makeexpr_bin(EK_LSH, tp_integer, grabarg(ex, 1), ex2);
    }
}



/* These bit-field operations were generalized slightly on the way to C;
 * they used to perform D &= S and now perform D = S1 & S2.
 */

Static Stmt *proc_na_bfand(ex)
Expr *ex;
{
    Stmt *sp;
    Meaning *tvar;

    if (!nosideeffects(ex->args[2], 1)) {
        tvar = makestmttempvar(ex->args[2]->val.type, name_TEMP);
        sp = makestmt_assign(makeexpr_var(tvar), ex->args[2]);
        ex->args[2] = makeexpr_var(tvar);
    } else
        sp = NULL;
    insertarg(&ex, 1, copyexpr(ex->args[2]));
    return makestmt_seq(sp, makestmt_call(ex));
}



Static Stmt *proc_na_bfbic(ex)
Expr *ex;
{
    return proc_na_bfand(ex);
}



Static Stmt *proc_na_bfor(ex)
Expr *ex;
{
    return proc_na_bfand(ex);
}



Static Stmt *proc_na_bfxor(ex)
Expr *ex;
{
    return proc_na_bfand(ex);
}



Static Expr *func_imin(ex)
Expr *ex;
{
    return makeexpr_bicall_2("P_imin2", tp_integer,
                             ex->args[0], ex->args[1]);
}



Static Expr *func_imax(ex)
Expr *ex;
{
    return makeexpr_bicall_2("P_imax2", tp_integer,
                             ex->args[0], ex->args[1]);
}



/* Unsigned non-overflowing arithmetic functions in Pascal; we translate
 * into plain arithmetic in C and assume C doesn't check for overflow.
 * (A valid assumption in the case when this was used.)
 */

Static Expr *func_na_add(ex)
Expr *ex;
{
    return makeexpr_plus(makeexpr_unlongcast(ex->args[0]),
                         makeexpr_unlongcast(ex->args[1]));
}



Static Expr *func_na_sub(ex)
Expr *ex;
{
    return makeexpr_minus(makeexpr_unlongcast(ex->args[0]),
                          makeexpr_unlongcast(ex->args[1]));
}



extern Stmt *proc_exit();    /* from funcs.c */

Static Stmt *proc_return()
{
    return proc_exit();
}



Static Expr *func_charupper(ex)
Expr *ex;
{
    return makeexpr_bicall_1("toupper", tp_char,
                             grabarg(ex, 0));
}



Static Expr *func_charlower(ex)
Expr *ex;
{
    return makeexpr_bicall_1("tolower", tp_char,
                             grabarg(ex, 0));
}



/* Convert an integer to its string representation.  We produce a sprintf
 * into a temporary variable; the temporary will probably be eliminated
 * as the surrounding code is translated.
 */

Static Expr *func_strint(ex)
Expr *ex;
{
    Expr *ex2;

    ex2 = makeexpr_forcelongness(ex->args[1]);
    return makeexpr_bicall_3("sprintf", ex->val.type,
                             ex->args[0],
                             makeexpr_string((exprlongness(ex2) > 0) ? "%ld" : "%d"),
                             ex2);
}



Static Expr *func_strint2(ex)
Expr *ex;
{
    Expr *ex2, *len, *fmt;

    if (checkconst(ex->args[2], 0) || checkconst(ex->args[2], 1))
        return func_strint(ex);
    if (expr_is_neg(ex->args[2])) {
	if (possiblesigns(ex->args[2]) & 4) {
            if (assumesigns)
                note("Assuming width for STRINT2 is negative [507]");
            else
                return ex;
        }
        ex2 = makeexpr_forcelongness(ex->args[1]);
        fmt = makeexpr_string((exprlongness(ex2) > 0) ? "%0*ld" : "%0*d");
        len = makeexpr_neg(makeexpr_longcast(ex->args[2], 0));
    } else {
	if (possiblesigns(ex->args[2]) & 1) {
            if (assumesigns)
                note("Assuming width for STRINT2 is positive [507]");
            else
                return ex;
        }
        ex2 = makeexpr_forcelongness(ex->args[1]);
        fmt = makeexpr_string((exprlongness(ex2) > 0) ? "%*ld" : "%*d");
        len = makeexpr_longcast(ex->args[2], 0);
    }
    ex = makeexpr_bicall_4("sprintf", ex->val.type,
                           ex->args[0], fmt, len, ex2);
    return cleansprintf(ex);
}



Static Expr *func_strhex(ex)
Expr *ex;
{
    Expr *ex2, *ex3;
    Value val;

    if (isliteralconst(ex->args[2], &val) == 2) {
        ex2 = makeexpr_forcelongness(ex->args[1]);
        if (val.i < 1 || val.i > 8) {
            ex = makeexpr_bicall_3("sprintf", ex->val.type,
                                   ex->args[0],
                                   makeexpr_string((exprlongness(ex2) > 0) ? "%lX" : "%X"),
                                   ex2);
        } else {
            if (val.i < 8) {
                ex3 = makeexpr_long((1 << (val.i*4)) - 1);
                insertarg(&ex3, 0, makeexpr_name("%#lx", tp_integer));
                ex2 = makeexpr_bin(EK_BAND, ex2->val.type, ex2, ex3);
            }
            ex = makeexpr_bicall_3("sprintf", ex->val.type,
                                   ex->args[0],
                                   makeexpr_string(format_d((exprlongness(ex2) > 0) ? "%%.%ldlX" :
                                                                                      "%%.%ldX",
                                                            val.i)),
                                   ex2);
        }
    }
    return ex;
}



Static Expr *func_strreal(ex)
Expr *ex;
{
    return makeexpr_bicall_3("sprintf", ex->val.type,
                             ex->args[0],
                             makeexpr_string("%g"),
                             ex->args[1]);
}



Static Expr *func_strchar(ex)
Expr *ex;
{
    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. */



