/*-
  Author: Brian Tiffin
  Dedicated to the public domain

  Date started: December 2016
  Modified: 2017-01-06/05:39-0500
+*/
/*
  A new Unicon C native FFI layer, with libffi
  Tectonics: gcc -o uniffi.so -shared -fPIC uniffi.c -lffi
  Phase 2 trial
     todo refactor the argument scanner
          work out ORing in the TYPESTAR arg override
*/
#include <stdio.h>
#include <ffi.h>

#include "icall.h"
#include "natives.h"

/* a dlopen handle */
static void *dlHandle;
/* a dlsym function pointer */
static void (*func)();

/* storage blob for arguments */
union blob {
    long lvalue;
    double rvalue;
    float fvalue;
    char *svalue;
};


#ifndef RTLD_LAZY                       /* normally from <dlfcn.h> */
#define RTLD_LAZY 1
#endif                                  /* RTLD_LAZY */

#if NT
void *
dlopen(char *name, int flag)
{ /* LoadLibrary */
    return (void *)LoadLibrary(name);
}
void *
dlsym(void *handle, char *sym)
{
    return (void *)GetProcAddress((HMODULE)handle, sym);
}
int
dlclose(void *handle)
{ /* FreeLibrary */
    return FreeLibrary((HMODULE)handle);
}

char *
dlerror(void)
{
    return "undiagnosed dynamic load error";
}
#else                                   /* NT */
#include <dlfcn.h>
#endif                                  /* NT */

#ifdef FreeBSD
/*
  If DL_GETERRNO exists, this is an FreeBSD 1.1.5 or 2.0 
  which lacks dlerror(); supply a substitute.
*/
#ifdef DL_GETERRNO
char *
dlerror(void)
{
    int no;

    if (0 == dlctl(NULL, DL_GETERRNO, &no))
        return(strerror(no));
    else
        return(NULL);
}
#endif
#endif                                  /* __FreeBSD__ */

int
ffi(int argc, descriptor argv[])
{

    /* ffi_retval will point to an appropriate return slot */
    void *ffi_retval;
    /* ffi_rettype will point to the address of an ffi_type indicator */
    void *ffi_rettype;

    /* The cif setup requires the return type and value slot */
    ffi_cif cif;

    /* allow for 127 arguments, the C standard minimum limit */
    ffi_type *args[127];
    void *values[127];

    /* a variant result block */
    ffi_arg rc;

    /* ffi library call result codes */
    int ffi_stat;

    /* function lookup name, and possible alternate */
    char *funcname;
    char *funcname2;

    /* dlsym lookup error messages */
    char *dlMsg;

    /* local copy of args, probably dumped in phase 2 */
    union blob ipregs[127];
    union blob fregs[127];

    /* the return type enum from Unicon, in natives.h */
    long retType;
    /* the base Unicon argument data type, may be overridden */
    char inType;

    /* pointed to by ffi_retval, for ffi_prep_cif */
    long intSlot;
    double doubleSlot;
    void *pointerSlot;
    float floatSlot;

    /* current count stashed arguments */
    int ips = 0;

    /* first the function name */
    ArgString(1);

    /* second is return type, from natives.inc matched in natives.h */
    ArgInteger(2);
    retType = IntegerVal(argv[2]);

    /* look up the function entry point */
    funcname = StringVal(argv[1]);
    dlerror();
    *(void **)(&func) = dlsym(dlHandle, funcname);
    dlMsg = dlerror();
    if (dlMsg) {
        fprintf(stderr, "dlsym fail: %s\n", dlMsg);
        fflush(stderr);
        Fail; //Error(500);
    }

    /* try alternative name with initial underscore */
    if (!func) {
        funcname2 = malloc(strlen(funcname + 2));
        if (funcname2) {
            *funcname2 = '_';
            strcpy(funcname2 + 1, funcname);
            *(void **)(&func) = dlsym(dlHandle, funcname2);
            free(funcname2);
        }
    }
    if (!func) Fail;

    /* Return type, pass an indirect pointer to ffi_call */
    switch(retType) {
    case TYPEVOID:
        ffi_rettype = &ffi_type_void;
        ffi_retval = NULL;
        break;
    case TYPESTAR:
        ffi_rettype = &ffi_type_pointer;
        ffi_retval = &pointerSlot;
        break;
    case TYPEINT:
        ffi_rettype = &ffi_type_slong;
        ffi_retval = &intSlot;
        break;
    case TYPEFLOAT:
        ffi_rettype = &ffi_type_float;
        ffi_retval = &floatSlot;
        break;
    case TYPEDOUBLE:
        ffi_rettype = &ffi_type_double;
        ffi_retval = &doubleSlot;
        break;
    case TYPESTRING:
        ffi_rettype = &ffi_type_pointer;
        ffi_retval = &pointerSlot;
        break;
    default:
        ffi_rettype = &ffi_type_slong;
        ffi_retval = &intSlot;
        break;
    }

    /* pull out types and values */
    for (int argi = 3; argi <= argc; argi++) {

        inType = IconType(argv[argi]);
        /*
          fprintf(stderr, "%d arg: %d, IconType: %d '%c'\n",
                argc, argi, inType, inType);
          fflush(stderr);
        */
        int llen;
        struct descrip slot[2];

        int forceType;

        switch(inType) {
        /* Special case for lists, second value is forced datatype */
        /* currently a cheater stub only handling double/float cases */
        case 'L':
            llen = ListLen(argv[argi]);
            if (llen != 2) {
                ipregs[ips].rvalue = 0.0;
                ipregs[ips].fvalue = 0.0;
                break;
            }
            /* from looking at IListVal and RListVal */
            cpslots(&argv[argi], &slot[0], 1, 3);
            forceType = IntegerVal(slot[1]);
            switch(forceType) {
            case TYPEFLOAT:
                ipregs[ips].fvalue = (float)RealVal(slot[0]);
                args[ips] = &ffi_type_float;
                values[ips] = &ipregs[ips].fvalue;
                ips++;
                break;
            case TYPEDOUBLE:
                ipregs[ips].rvalue = RealVal(slot[0]);
                fregs[ips].rvalue = RealVal(slot[0]);
                args[ips] = &ffi_type_double;
                values[ips] = &(fregs[ips].rvalue);
                ips++;
                break;
            default:
                fprintf(stderr, "forceType %d not yet supported\n",
                        forceType);
                fflush(stderr);
                break;
            }
            break;
        case 'i':
            ArgInteger(argi);
            ipregs[ips].lvalue = IntegerVal(argv[argi]);

            args[ips] = &ffi_type_slong;
            values[ips] = &(ipregs[ips].lvalue);
            ips++;
            break;
        case 'r':
            ArgReal(argi);
            fregs[ips].rvalue = RealVal(argv[argi]);
            args[ips] = &ffi_type_double;
            values[ips] = &(fregs[ips].rvalue);
            ips++;
            break;
        case 's':
            ArgString(argi);
            ipregs[ips].svalue = StringVal(argv[argi]);

            args[ips] = &ffi_type_pointer;
            values[ips] = &(ipregs[ips].svalue);
            ips++;
            break;
        }
    }

    /* Initialize the cif */
    ffi_stat = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, argc - 2,
                            ffi_rettype, args);

    if (ffi_stat == FFI_OK) {
        /* the magic call */
        ffi_call(&cif, *func, ffi_retval, values);
    } else {
        fprintf(stderr, "ffi_prep_cif failed: %d\n", ffi_stat);
        fflush(stderr);
        Fail;
    }

    /* Return type, as specfied in argument 2 enum */
    switch(retType) {
    case TYPEVOID:
        Return;
        break;
    case TYPESTAR:
        RetInteger((long)pointerSlot);
        break;
    case TYPEINT:
        RetInteger(intSlot);
        break;
    case TYPEFLOAT:
        RetReal(floatSlot);
        break;
    case TYPEDOUBLE:
        RetReal(doubleSlot);
        break;
    case TYPESTRING:
        RetString(pointerSlot);
        break;
    default:
        RetInteger(intSlot);
        break;
    }
    Error(500);
}

/* add a library to the dlsym search path */
/* need to pull code from src/runtime/fload.r */
int
addLibrary(int argc, descriptor argv[])
{
    //union block dlBlock;
    //descriptor dlBlock;
    /* Add a new library to the dynamic search path */
    ArgString(1)
    dlHandle = dlopen(StringVal(argv[1]), RTLD_LAZY | RTLD_GLOBAL);
    if (!dlHandle) {
        /*
          fprintf(stderr, "dlHandle error\n");
          fflush(stderr);
          Error(500);
        */
        Fail;
    }

    /* The return pointer, needs to get stashed properly */
    //dlBlock = mkExternal(dlHandle, sizeof(dlHandle));
    //RetExternal(dlBlock);
    RetInteger((long)dlHandle);
}