/* -*- Mode: C; c-basic-offset:4 ; -*- */

/*

 *

 *  (C) 2012 by Argonne National Laboratory.

 *      See COPYRIGHT in top-level directory.

 */

#include <stdio.h>

#include "mpi.h"

#include <stdlib.h>

#include <string.h>

#include "../../include/mpitestconf.h"

/* Used to convert Fortran strings (which may not be null terminated) to

   C strings */

#define MAX_ATTRTEST_MSG 256

/*

 * FIXME: This code assumes that character strings are passed from Fortran

 * by placing the string length, as an int, at the end of the argument list

 * This is common but not universal.

 */

/*

   Name mapping.  All routines are created with names that are lower case

   with a single trailing underscore.  This matches many compilers.

   We use #define to change the name for Fortran compilers that do

   not use the lowercase/underscore pattern

*/

#ifdef F77_NAME_UPPER

#define cattrinit_   CATTRINIT

#define cgetenvbool_ CGETENVBOOL

#define cgetsizes_   CGETSIZES

#define ccreatekeys_ CCREATEKEYS

#define cfreekeys_   CFREEKEYS

#define ctoctest_    CTOCTEST

#define cmpif1read_  CMPIF1READ

#define cmpif2read_  CMPIF2READ

#define cmpif2readtype_  CMPIF2READTYPE

#define cmpif2readwin_   CMPIF2READWIN

#define csetmpi_     CSETMPI

#define csetmpi2_    CSETMPI2

#define csetmpitype_ CSETMPITYPE

#define csetmpiwin_  CSETMPIWIN

#elif defined(F77_NAME_LOWER) || defined(F77_NAME_MIXED)

/* Mixed is ok because we use lowercase in all uses */

#define cattrinit_   cattrinit

#define cgetenvbool_ cgetenvbool

#define cgetsizes_   cgetsizes

#define ccreatekeys_ ccreatekeys

#define cfreekeys_   cfreekeys

#define ctoctest_    ctoctest

#define cmpif1read_  cmpif1read

#define cmpif2read_  cmpif2read

#define cmpif2readtype_  cmpif2readtype

#define cmpif2readwin_   cmpif2readwin

#define csetmpi_     csetmpi

#define csetmpi2_    csetmpi2

#define csetmpitype_ csetmpitype

#define csetmpiwin_  csetmpiwin

#elif defined(F77_NAME_LOWER_2USCORE) || defined(F77_NAME_LOWER_USCORE) || \

      defined(F77_NAME_MIXED_USCORE)

/* Else leave name alone (routines have no underscore, so both

   of these map to a lowercase, single underscore) */

#else

#error 'Unrecognized Fortran name mapping'

#endif

/* */

static int ccomm1Key, ccomm2Key, ctype2Key, cwin2Key;

static int ccomm1Extra, ccomm2Extra, ctype2Extra, cwin2Extra;

static int verbose = 0;

/* Forward references */

int cmpi1read(MPI_Comm comm, int key, void *expected, const char *msg);

int cmpi2read(MPI_Comm comm, int key, void *expected, const char *msg);

int cmpi2readtype(MPI_Datatype dtype, int key, void *expected, const char *msg);

void ccompareint2aint_(MPI_Fint * in1, MPI_Aint * in2, MPI_Fint * result);

void ccompareint2void_(MPI_Fint * in1, void *in2, MPI_Fint * result);

void ccompareaint2void_(MPI_Aint * in1, void *in2, MPI_Fint * result);

/* ----------------------------------------------------------------------- */

/* Initialization functions                                                */

/* ----------------------------------------------------------------------- */

void cgetenvbool_(const char str[], MPI_Fint * val, int d)

{

    const char *envval;

    char envname[1024];

    /* Note that the Fortran string may not be null terminated; thus

     * we copy d characters and add a null just in case */

    if (d > sizeof(envname) - 1) {

        fprintf(stderr, "Environment variable name too long (%d)\n", d);

        MPI_Abort(MPI_COMM_WORLD, 1);

    }

    strncpy(envname, str, d);

    envname[d] = 0;

    envval = getenv(envname);

    *val = 0;

    if (envval) {

        printf(" envval = %s\n", envval);

        if (strcmp(envval, "yes") == 0 || strcmp(envval, "YES") == 0 ||

            strcmp(envval, "true") == 0 || strcmp(envval, "TRUE") == 0)

            *val = 1;

    }

}

/* Keep our own copy of the "is verbose" state */

void cattrinit_(MPI_Fint * fverbose)

{

    verbose = (int) *fverbose;

}

/* Provide attribute sizes (C, Fortran 1, Fortran 2) */

void cgetsizes_(MPI_Fint * ptrSize, MPI_Fint * intSize, MPI_Fint * aintSize)

{

    *ptrSize = (MPI_Fint) sizeof(void *);

    *intSize = (MPI_Fint) sizeof(MPI_Fint);

    *aintSize = (MPI_Fint) sizeof(MPI_Aint);

}

/* ----------------------------------------------------------------------- */

/* Copy and delete functions attached to keyvals                           */

/* ----------------------------------------------------------------------- */

static int CMPI1_COPY_FN(MPI_Comm comm, int keyval, void *extra,

                         void *inval, void *outval, int *flag)

{

    int inValue = *(int *) inval;

    if (verbose)

        printf(" In C MPI-1 copy function: inval = %p, extra = %p\n", inval, extra);

    *flag = 1;

    /* We don't change the attribute */

    *(void **) outval = inval;

    /* But we do change what it points at */

    *(int *) inval = inValue + 1;

    return MPI_SUCCESS;

}

static int CMPI1_DELETE_FN(MPI_Comm comm, int keyval, void *outval, void *extra)

{

    if (verbose)

        printf(" In C MPI-1 delete function, extra = %p\n", extra);

    *(int *) outval = *(int *) outval - 1;

    return MPI_SUCCESS;

}

static int TYPE_COPY_FN(MPI_Datatype dtype, int keyval, void *extra,

                        void *inval, void *outval, int *flag)

{

    int inValue = *(int *) inval;

    if (verbose)

        printf(" In C MPI type copy function, inval = %p, extra = %p\n", inval, extra);

    *flag = 1;

    /* We don't change the attribute */

    *(void **) outval = inval;

    /* But we do change what it points at */

    *(int *) inval = inValue + 1;

    return MPI_SUCCESS;

}

static int TYPE_DELETE_FN(MPI_Datatype dtype, int keyval, void *outval, void *extra)

{

    if (verbose)

        printf(" In C MPI type delete function, extra = %p\n", extra);

    /* We reverse the incrment used in copy (checked after free of the type) */

    *(int *) outval = *(int *) outval - 1;

    return MPI_SUCCESS;

}

/* Note that this function cannot be called in MPI since there is no

   win_dup function */

static int WIN_COPY_FN(MPI_Win win, int keyval, void *extra, void *inval, void *outval, int *flag)

{

    int inValue = *(int *) inval;

    if (verbose)

        printf("PANIC: In C MPI win copy function (should never happen)\n");

    *flag = 1;

    return MPI_SUCCESS;

}

static int WIN_DELETE_FN(MPI_Win win, int keyval, void *outval, void *extra)

{

    if (verbose)

        printf(" In C MPI win delete function, extra = %p\n", extra);

    *(int *) outval = *(int *) outval - 1;

    return MPI_SUCCESS;

}

/* ----------------------------------------------------------------------- */

/* Routines to create keyvals in C (with C copy and delete functions       */

/* ----------------------------------------------------------------------- */

void ccreatekeys_(MPI_Fint * ccomm1_key, MPI_Fint * ccomm2_key,

                  MPI_Fint * ctype2_key, MPI_Fint * cwin2_key)

{

    MPI_Keyval_create(CMPI1_COPY_FN, CMPI1_DELETE_FN, &ccomm1Key, &ccomm1Extra);

    *ccomm1_key = (MPI_Fint) ccomm1Key;

    MPI_Comm_create_keyval(CMPI1_COPY_FN, CMPI1_DELETE_FN, &ccomm2Key, &ccomm2Extra);

    *ccomm2_key = (MPI_Fint) ccomm2Key;

    MPI_Type_create_keyval(TYPE_COPY_FN, TYPE_DELETE_FN, &ctype2Key, &ctype2Extra);

    *ctype2_key = (MPI_Fint) ctype2Key;

    MPI_Win_create_keyval(WIN_COPY_FN, WIN_DELETE_FN, &cwin2Key, &cwin2Extra);

    *cwin2_key = (MPI_Fint) cwin2Key;

}

void cfreekeys_(void)

{

    MPI_Keyval_free(&ccomm1Key);

    MPI_Comm_free_keyval(&ccomm2Key);

    MPI_Type_free_keyval(&ctype2Key);

    MPI_Win_free_keyval(&cwin2Key);

}

/* ----------------------------------------------------------------------- */

/* ----------------------------------------------------------------------- */

/* Test c-to-c attributes */

static int ccomm1Attr, ccomm2Attr, ctype2Attr, cwin2Attr;

void ctoctest_(MPI_Fint * errs)

{

    int errcnt = *errs;

    int baseattrval = (1 << (sizeof(int) * 8 - 2)) - 3;

    MPI_Datatype cduptype;

    MPI_Comm cdup;

    /* MPI-1 function */

    ccomm1Attr = baseattrval;

    MPI_Attr_put(MPI_COMM_SELF, ccomm1Key, &ccomm1Attr);

    /* Test that we have the same value */

    errcnt += cmpi1read(MPI_COMM_SELF, ccomm1Key, &ccomm1Attr, "C to C");

    /* Dup, check that the copy routine does what is expected */

    MPI_Comm_dup(MPI_COMM_SELF, &cdup);

    errcnt += cmpi1read(cdup, ccomm1Key, &ccomm1Attr, "C to C dup");

    if (ccomm1Attr != baseattrval + 1) {

        printf(" Did not increment int in C to C dup: %d %d\n", ccomm1Attr, baseattrval + 1);

        errcnt++;

    }

    MPI_Comm_free(&cdup);

    if (ccomm1Attr != baseattrval) {

        printf(" Did not increment int in C to C delete: %d %d\n", ccomm1Attr, baseattrval);

        errcnt++;

    }

    /* MPI-2 functions */

    ccomm1Attr = 0;

    ccomm2Attr = baseattrval;

    MPI_Comm_set_attr(MPI_COMM_SELF, ccomm2Key, &ccomm2Attr);

    /* Test that we have the same value */

    errcnt += cmpi2read(MPI_COMM_SELF, ccomm2Key, &ccomm2Attr, "C to C (2)");

    /* Dup, check that the copy routine does what is expected */

    MPI_Comm_dup(MPI_COMM_SELF, &cdup);

    errcnt += cmpi2read(cdup, ccomm2Key, &ccomm2Attr, "C to C dup (2)");

    if (ccomm2Attr != baseattrval + 1) {

        printf(" Did not increment int in C to C dup: %d %d\n", ccomm2Attr, baseattrval + 1);

        errcnt++;

    }

    MPI_Comm_free(&cdup);

    if (ccomm2Attr != baseattrval) {

        printf(" Did not increment int in C to C delete (2): %d %d\n", ccomm2Attr, baseattrval);

        errcnt++;

    }

    /* MPI-2 functions */

    ctype2Attr = baseattrval;

    MPI_Type_set_attr(MPI_INTEGER, ctype2Key, &ctype2Attr);

    /* Test that we have the same value */

    errcnt += cmpi2readtype(MPI_INTEGER, ctype2Key, &ctype2Attr, "C to C type (2)");

    /* Dup, check that the copy routine does what is expected */

    MPI_Type_dup(MPI_INTEGER, &cduptype);

    errcnt += cmpi2readtype(cduptype, ctype2Key, &ctype2Attr, "C to C typedup (2)");

    if (ctype2Attr != baseattrval + 1) {

        printf(" Did not increment int in C to C typedup: %d %d\n", ctype2Attr, baseattrval + 1);

        errcnt++;

    }

    ccomm1Attr = 0;

    MPI_Type_free(&cduptype);

    if (ctype2Attr != baseattrval) {

        printf(" Did not increment int in C to C typedelete (2): %d %d\n", ctype2Attr, baseattrval);

        errcnt++;

    }

    *errs = errcnt;

}

/* ----------------------------------------------------------------------- */

/* Routines to get and check an attribute value.  Returns the number       */

/*   of errors found                                                       */

/* ----------------------------------------------------------------------- */

int cmpi1read(MPI_Comm comm, int key, void *expected, const char *msg)

{

    void *attrval;

    int flag;

    MPI_Attr_get(comm, key, &attrval, &flag;;

    if (!flag) {

        printf(" Error: flag false for Attr_get: %s\n", msg);

        return 1;

    }

    if (attrval != expected) {

        printf(" Error: expected %p but saw %p: %s\n", expected, attrval, msg);

        return 1;

    }

    return 0;

}

int cmpi2read(MPI_Comm comm, int key, void *expected, const char *msg)

{

    void *attrval;

    int flag;

    MPI_Comm_get_attr(comm, key, &attrval, &flag;;

    if (!flag) {

        printf(" Error: flag false for Comm_get_attr: %s\n", msg);

        return 1;

    }

    if (attrval != expected) {

        printf(" Error: expected %p but saw %p: %s\n", expected, attrval, msg);

        return 1;

    }

    return 0;

}

int cmpi2readtype(MPI_Datatype dtype, int key, void *expected, const char *msg)

{

    void *attrval;

    int flag;

    MPI_Type_get_attr(dtype, key, &attrval, &flag;;

    if (!flag) {

        printf(" Error: flag false for Type_get_attr: %s\n", msg);

        return 1;

    }

    if (attrval != expected) {

        printf(" Error: expected %p but saw %p: %s\n", expected, attrval, msg);

        return 1;

    }

    return 0;

}

int cmpi2readwin(MPI_Win win, int key, void *expected, const char *msg)

{

    void *attrval;

    int flag;

    MPI_Win_get_attr(win, key, &attrval, &flag;;

    if (!flag) {

        printf(" Error: flag false for Win_get_attr: %s\n", msg);

        return 1;

    }

    if (attrval != expected) {

        printf(" Error: expected %p but saw %p: %s\n", expected, attrval, msg);

        return 1;

    }

    return 0;

}

/* Set in Fortran (MPI-1), read in C */

void cmpif1read_(MPI_Fint * fcomm, MPI_Fint * fkey, MPI_Fint * expected,

                 MPI_Fint * errs, const char *msg, int msglen)

{

    void *attrval;

    int flag, result;

    MPI_Comm comm = MPI_Comm_f2c(*fcomm);

    char lmsg[MAX_ATTRTEST_MSG];

    if (msglen > sizeof(lmsg) - 1) {

        fprintf(stderr, "Message too long for buffer (%d)\n", msglen);

        MPI_Abort(MPI_COMM_WORLD, 1);

    }

    MPI_Attr_get(comm, *fkey, &attrval, &flag;;

    if (!flag) {

        *errs = *errs + 1;

        strncpy(lmsg, msg, msglen);

        lmsg[msglen] = 0;

        printf(" Error: flag false for Attr_get (set in F1): %s\n", lmsg);

        return;

    }

    /* Must be careful to compare as required in the MPI specification */

    ccompareint2void_(expected, attrval, &result);

    if (!result) {

        *errs = *errs + 1;

        strncpy(lmsg, msg, msglen);

        lmsg[msglen] = 0;

        printf(" Error: (set in F1) expected %d but saw %d: %s\n",

               *expected, *(MPI_Fint *) attrval, lmsg);

        return;

    }

    return;

}

/* Set in Fortran (MPI-2), read in C */

void cmpif2read_(MPI_Fint * fcomm, MPI_Fint * fkey, MPI_Aint * expected,

                 MPI_Fint * errs, const char *msg, int msglen)

{

    void *attrval;

    int flag, result;

    MPI_Comm comm = MPI_Comm_f2c(*fcomm);

    char lmsg[MAX_ATTRTEST_MSG];

    if (msglen > sizeof(lmsg) - 1) {

        fprintf(stderr, "Message too long for buffer (%d)\n", msglen);

        MPI_Abort(MPI_COMM_WORLD, 1);

    }

    MPI_Comm_get_attr(comm, *fkey, &attrval, &flag;;

    if (!flag) {

        *errs = *errs + 1;

        strncpy(lmsg, msg, msglen);

        lmsg[msglen] = 0;

        printf(" Error: flag false for Comm_get_attr (set in F2): %s\n", lmsg);

        return;

    }

    ccompareaint2void_(expected, attrval, &result);

    if (!result) {

        *errs = *errs + 1;

        strncpy(lmsg, msg, msglen);

        lmsg[msglen] = 0;

        printf(" Error: (set in F2) expected %ld but saw %ld: %s\n",

               (long) *expected, (long) *(MPI_Aint *) attrval, lmsg);

        return;

    }

    return;

}

void cmpif2readtype_(MPI_Fint * ftype, MPI_Fint * fkey, MPI_Aint * expected,

                     MPI_Fint * errs, const char *msg, int msglen)

{

    void *attrval;

    int flag, result;

    MPI_Datatype dtype = MPI_Type_f2c(*ftype);

    char lmsg[MAX_ATTRTEST_MSG];

    if (msglen > sizeof(lmsg) - 1) {

        fprintf(stderr, "Message too long for buffer (%d)\n", msglen);

        MPI_Abort(MPI_COMM_WORLD, 1);

    }

    MPI_Type_get_attr(dtype, *fkey, &attrval, &flag;;

    if (!flag) {

        *errs = *errs + 1;

        strncpy(lmsg, msg, msglen);

        lmsg[msglen] = 0;

        printf(" Error: flag false for Type_get_attr (set in F2): %s\n", lmsg);

        return;

    }

    ccompareaint2void_(expected, attrval, &result);

    if (!result) {

        *errs = *errs + 1;

        strncpy(lmsg, msg, msglen);

        lmsg[msglen] = 0;

        printf(" Error: (set in F2/Type) expected %ld but saw %ld: %s\n",

               (long) *expected, (long) *(MPI_Aint *) attrval, lmsg);

        return;

    }

    return;

}

void cmpif2readwin_(MPI_Fint * fwin, MPI_Fint * fkey, MPI_Aint * expected,

                    MPI_Fint * errs, const char *msg, int msglen)

{

    void *attrval;

    int flag, result;

    MPI_Win win = MPI_Win_f2c(*fwin);

    char lmsg[MAX_ATTRTEST_MSG];

    if (msglen > sizeof(lmsg) - 1) {

        fprintf(stderr, "Message too long for buffer (%d)\n", msglen);

        MPI_Abort(MPI_COMM_WORLD, 1);

    }

    MPI_Win_get_attr(win, *fkey, &attrval, &flag;;

    if (!flag) {

        *errs = *errs + 1;

        strncpy(lmsg, msg, msglen);

        lmsg[msglen] = 0;

        printf(" Error: flag false for Win_get_attr (set in F2): %s\n", lmsg);

        return;

    }

    ccompareaint2void_(expected, attrval, &result);

    if (!result) {

        *errs = *errs + 1;

        strncpy(lmsg, msg, msglen);

        lmsg[msglen] = 0;

        printf(" Error: (set in F2/Win) expected %ld but saw %ld: %s\n",

               (long) *expected, (long) *(MPI_Aint *) attrval, lmsg);

        return;

    }

    return;

}

/* ----------------------------------------------------------------------- */

/* Given a Fortran attribute (pointer to the value to store), set it using */

/* the C attribute functions                                               */

/* ----------------------------------------------------------------------- */

void csetmpi_(MPI_Fint * fcomm, MPI_Fint * fkey, MPI_Fint * val, MPI_Fint * errs)

{

    MPI_Comm comm = MPI_Comm_f2c(*fcomm);

    MPI_Comm_set_attr(comm, *fkey, (void *) (MPI_Aint) * val);

}

void csetmpi2_(MPI_Fint * fcomm, MPI_Fint * fkey, MPI_Aint * val, MPI_Fint * errs)

{

    MPI_Comm comm = MPI_Comm_f2c(*fcomm);

    MPI_Comm_set_attr(comm, *fkey, (void *) *val);

}

void csetmpitype_(MPI_Fint * ftype, MPI_Fint * fkey, MPI_Aint * val, MPI_Fint * errs)

{

    MPI_Datatype dtype = MPI_Type_f2c(*ftype);

    MPI_Type_set_attr(dtype, *fkey, (void *) *val);

}

void csetmpiwin_(MPI_Fint * fwin, MPI_Fint * fkey, MPI_Aint * val, MPI_Fint * errs)

{

    MPI_Win win = MPI_Win_f2c(*fwin);

    MPI_Win_set_attr(win, *fkey, (void *) *val);

}

/* ----------------------------------------------------------------------- */

/* Comparisons                                                             */

/*    int with aint                                                        */

/*    int with void*                                                       */

/*    aint with void*                                                      */

/* All routines use similar interfaces, though the routines that involve   */

/* void * must be called from C                                            */

/* Defined to be callable from either C or Fortran                         */

/* Here is the rule, defined in the MPI standard:                          */

/*    If one item is shorter than the other, take the low bytes.           */

/*    If one item is longer than the other, sign extend                    */

/* ----------------------------------------------------------------------- */

void ccompareint2aint_(MPI_Fint * in1, MPI_Aint * in2, MPI_Fint * result)

{

    static int idx = -1;

    if (sizeof(MPI_Fint) == sizeof(MPI_Aint)) {

        *result = *in1 == *in2;

    }

    else if (sizeof(MPI_Fint) < sizeof(MPI_Aint)) {

        /* Assume Aint no smaller than Fint, and that size of aint

         * is a multiple of the size of fint) */

        MPI_Fint *v2 = (MPI_Fint *) in2;

        if (idx < 0) {

            MPI_Aint av = 1;

            MPI_Fint *fa = (MPI_Fint *) & av;

            if ((sizeof(MPI_Aint) % sizeof(MPI_Fint)) != 0) {

                fprintf(stderr,

                        "PANIC: size of MPI_Aint = %d not a multiple of MPI_Fint = %d\n",

                        (int) sizeof(MPI_Aint), (int) sizeof(MPI_Fint));

                MPI_Abort(MPI_COMM_WORLD, 1);

            }

            for (idx = sizeof(MPI_Aint) / sizeof(MPI_Fint); idx >= 0; idx--)

                if (fa[idx])

                    break;

            if (idx < 0) {

                fprintf(stderr, "Unable to determine low word of Fint in Aint\n");

                MPI_Abort(MPI_COMM_WORLD, 1);

            }

            *result = *in1 == v2[idx];

        }

    }

    else {

        fprintf(stderr, "PANIC: sizeof(MPI_Fint) = %d > sizeof(MPI_Aint) %d\n",

                (int) sizeof(MPI_Fint), (int) sizeof(MPI_Aint));

        MPI_Abort(MPI_COMM_WORLD, 1);

    }

}

void ccompareint2void_(MPI_Fint * in1, void *in2, MPI_Fint * result)

{

    static int idx = -1;

    if (sizeof(MPI_Fint) == sizeof(void *)) {

        *result = *in1 == *(MPI_Fint *) in2;

    }

    else if (sizeof(MPI_Fint) < sizeof(void *)) {

        /* Assume void* no smaller than Fint, and that size of aint

         * is a multiple of the size of fint) */

        MPI_Fint *v2 = (MPI_Fint *) in2;

        if (idx < 0) {

            void *av = (void *) 1;

            MPI_Fint *fa = (MPI_Fint *) & av;

            if ((sizeof(void *) % sizeof(MPI_Fint)) != 0) {

                fprintf(stderr,

                        "PANIC: size of void * = %d not a multiple of MPI_Fint = %d\n",

                        (int) sizeof(void *), (int) sizeof(MPI_Fint));

                MPI_Abort(MPI_COMM_WORLD, 1);

            }

            for (idx = sizeof(void *) / sizeof(MPI_Fint); idx >= 0; idx--)

                if (fa[idx])

                    break;

            if (idx < 0) {

                fprintf(stderr, "Unable to determine low word of Fint in void*\n");

                MPI_Abort(MPI_COMM_WORLD, 1);

            }

            *result = *in1 == v2[idx];

        }

    }

    else {

        fprintf(stderr, "PANIC: sizeof(MPI_Fint) = %d > sizeof(void*) %d\n",

                (int) sizeof(MPI_Fint), (int) sizeof(void *));

        MPI_Abort(MPI_COMM_WORLD, 1);

    }

}

void ccompareaint2void_(MPI_Aint * in1, void *in2, MPI_Fint * result)

{

    /* Note that an aint must be >= void * by definition */

    *result = *in1 == *(MPI_Aint *) in2;

}