debian
/
newlisp
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
newlisp/nl-import.c

1185 lines
34 KiB
C
Raw Permalink Blame History

/* nl-import.c --- shared library interface for newLISP
Copyright (C) 2016 Lutz Mueller
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, either version 3 of the License, or
(at your option) any later 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. If not, see <http://www.gnu.org/licenses/>.
*/
#include "newlisp.h"
#include "protos.h"
#ifndef WINDOWS
#include <dlfcn.h>
#endif
#ifdef MAC_OSX
#include <sys/mman.h>
#endif
UINT cdeclFunction(UINT fAddress, UINT * args, int count);
extern int evalCatchFlag;
#ifdef FFI
CELL * ffiPreparation(CELL * pCell, CELL * params, int type);
CELL * ffiTypeToCell(ffi_type *type, void * src);
CELL * unpackFFI(ffi_type * ffi, char * data);
void ffi_trampoline(ffi_cif *cif, void *ret, void **args, void *symbol);
#endif
#if defined(WINDOWS) || defined(CYGWIN)
UINT stdcallFunction(UINT fAddress, UINT * args, int count);
#endif
#ifdef WINDOWS
CELL * p_importLib(CELL * params)
{
char * libName;
char * funcName;
char * options = NULL;
HINSTANCE hLibrary;
CELL * pCell;
SYMBOL * symbol;
FARPROC initProc;
int type = CELL_IMPORT_DLL;
params = getString(params, &libName);
params = getString(params, &funcName);
if(params != nilCell)
{
if(params->next == nilCell)
params = getString(params, &options);
#ifdef FFI
else
type = CELL_IMPORT_FFI;
#endif
}
if( (UINT)(hLibrary = LoadLibrary(libName)) < 32)
return(errorProcExt2(ERR_IMPORT_LIB_NOT_FOUND, stuffString(libName)));
if(options != NULL && strcmp(options, "cdecl") == 0)
type = CELL_IMPORT_CDECL;
symbol = translateCreateSymbol(funcName, type, currentContext, TRUE);
if(isFFIsymbol(symbol->flags)) /* don't redefine return current def */
return (copyCell((CELL *)symbol->contents));
if(isProtected(symbol->flags))
return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
pCell = getCell(type);
deleteList((CELL *)symbol->contents);
symbol->contents = (UINT)pCell;
if((pCell->contents = (UINT)GetProcAddress(hLibrary, (LPCSTR)funcName)) == 0)
return(errorProcExt2(ERR_IMPORT_FUNC_NOT_FOUND, stuffString(funcName)));
/* put name of imported DLL into DLLs space for loadStartup() */
initProc = GetProcAddress(hLibrary, (LPCSTR)"dllName");
if(initProc != 0) (*initProc)(libName);
#ifdef FFI
symbol->flags |= SYMBOL_FFI | SYMBOL_PROTECTED;
if(pCell->type == CELL_IMPORT_FFI)
{
pCell->aux = (UINT)calloc(sizeof(FFIMPORT), 1);
((FFIMPORT *)pCell->aux)->name = symbol->name;
return(copyCell(ffiPreparation(pCell, params, FFI_FUNCTION)));
}
#endif
pCell->aux = (UINT)symbol->name;
return(copyCell(pCell));
}
#else /* UNIX and compatible operating systems */
CELL * p_importLib(CELL * params)
{
char * libName;
char * funcName;
void * hLibrary;
CELL * pCell;
SYMBOL * symbol;
char * error;
#ifdef CYGWIN
char * options = NULL;
int type = CELL_IMPORT_DLL;
#else
int type = CELL_IMPORT_CDECL;
#endif
params = getString(params, &libName);
if(params != nilCell)
params = getString(params, &funcName);
else funcName = NULL;
#ifdef CYGWIN
if(params != nilCell)
{
if(params->next == nilCell)
{
params = getString(params, &options);
if(strcmp(options, "cdecl") == 0)
type = CELL_IMPORT_CDECL;
}
#ifdef FFI
else type = CELL_IMPORT_FFI;
#endif
}
#else
if(params->next != nilCell)
type = CELL_IMPORT_FFI;
#endif
hLibrary = 0;
#ifdef TRU64
if((hLibrary = dlopen(libName, RTLD_LAZY)) == 0)
#else
if((hLibrary = dlopen(libName, RTLD_GLOBAL|RTLD_LAZY)) == 0)
#endif
return(errorProcExt2(ERR_IMPORT_LIB_NOT_FOUND, stuffString((char *)dlerror())));
if(funcName == NULL)
return(trueCell);
symbol = translateCreateSymbol(funcName, type, currentContext, TRUE);
if(isFFIsymbol(symbol->flags)) /* don't redefine */
return (copyCell((CELL *)symbol->contents));
if(isProtected(symbol->flags))
return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
pCell = getCell(type);
deleteList((CELL *)symbol->contents);
symbol->contents = (UINT)pCell;
dlerror(); /* clear potential error */
pCell->contents = (UINT)dlsym(hLibrary, funcName);
if((error = (char *)dlerror()) != NULL)
return(errorProcExt2(ERR_IMPORT_FUNC_NOT_FOUND, stuffString(error)));
#ifdef FFI
symbol->flags |= SYMBOL_FFI | SYMBOL_PROTECTED;
if(pCell->type == CELL_IMPORT_FFI)
{
pCell->aux = (UINT)calloc(sizeof(FFIMPORT), 1);
((FFIMPORT *)pCell->aux)->name = symbol->name;
return(copyCell(ffiPreparation(pCell, params, FFI_FUNCTION)));
}
#endif
pCell->aux = (UINT)symbol->name;
return(copyCell(pCell));
}
#endif
CELL * executeLibfunction(CELL * pCell, CELL * params)
{
CELL * arg;
UINT args[14];
int count;
#ifdef FFI
if(pCell->type == CELL_IMPORT_FFI)
if(((FFIMPORT *)pCell->aux)->type != 0)
return executeLibFFI(pCell, params);
#endif
count = 0;
while(params->type != CELL_NIL && count < 14)
{
arg = evaluateExpression(params);
switch(arg->type)
{
case CELL_LONG:
case CELL_STRING:
case CELL_PRIMITIVE:
args[count++] = arg->contents;
break;
#ifndef NEWLISP64
/* change 64-bit to 32-bit */
case CELL_INT64:
args[count++] = *(INT64 *)&arg->aux;
break;
#endif
case CELL_FLOAT:
#ifndef NEWLISP64
args[count++] = arg->aux;
#endif
args[count++] = arg->contents;
break;
default:
args[count++] = (UINT)arg;
break;
}
params = (CELL *)params->next;
}
#if defined(WINDOWS) || defined(CYGWIN)
if(pCell->type == CELL_IMPORT_DLL)
return(stuffInteger(stdcallFunction(pCell->contents, args, count)));
else
#endif
return(stuffInteger(cdeclFunction(pCell->contents, args, count)));
}
UINT cdeclFunction(UINT fAddress, UINT * args, int count)
{
UINT (*function)();
function = (UINT (*)())fAddress;
switch(count)
{
case 0:
return (*function)();
case 1:
return (*function)(args[0]);
case 2:
return (*function)(args[0], args[1]);
case 3:
/* printf("args[0] %llx, args[1] %llx, args[2] %llx, args[1]-args[2] %llx\n ",
args[0], args[1], args[2], args[1] - args[2]); */
return (*function)(args[0], args[1], args[2]);
case 4:
return (*function)(args[0], args[1], args[2], args[3]);
case 5:
return (*function)(args[0], args[1], args[2], args[3],
args[4]);
case 6:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5]);
case 7:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5], args[6]);
case 8:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5], args[6], args[7]);
case 9:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5], args[6], args[7], args[8]);
case 10:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5], args[6], args[7], args[8], args[9]);
case 11:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5], args[6], args[7],
args[8], args[9], args[10]);
case 12:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5], args[6], args[7],
args[8], args[9], args[10], args[11]);
case 13:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5], args[6], args[7],
args[8], args[9], args[10], args[11],
args[12]);
case 14:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5], args[6], args[7],
args[8], args[9], args[10], args[11],
args[12], args[13]);
default:
break;
}
return(0);
}
#if defined(WINDOWS) || defined(CYGWIN)
UINT stdcallFunction(UINT fAddress, UINT * args, int count)
{
UINT _stdcall (*function)();
function = (UINT _stdcall (*)())fAddress;
switch(count)
{
case 0:
return (*function)();
case 1:
return (*function)(args[0]);
case 2:
return (*function)(args[0], args[1]);
case 3:
return (*function)(args[0], args[1], args[2]);
case 4:
return (*function)(args[0], args[1], args[2], args[3]);
case 5:
return (*function)(args[0], args[1], args[2], args[3],
args[4]);
case 6:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5]);
case 7:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5], args[6]);
case 8:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5], args[6], args[7]);
case 9:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5], args[6], args[7], args[8]);
case 10:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5], args[6], args[7], args[8], args[9]);
case 11:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5], args[6], args[7],
args[8], args[9], args[10]);
case 12:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5], args[6], args[7],
args[8], args[9], args[10], args[11]);
case 13:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5], args[6], args[7],
args[8], args[9], args[10], args[11],
args[12]);
case 14:
return (*function)(args[0], args[1], args[2], args[3],
args[4], args[5], args[6], args[7],
args[8], args[9], args[10], args[11],
args[12], args[13]);
default:
break;
}
return(0);
}
#endif
/* 16 callback functions for up to 8 parameters */
INT template(INT n, INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8);
INT callback0(INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8)
{return template(0, p1, p2, p3, p4, p5, p6, p7, p8);}
INT callback1(INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8)
{return template(1, p1, p2, p3, p4, p5, p6, p7, p8);}
INT callback2(INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8)
{return template(2, p1, p2, p3, p4, p5, p6, p7, p8);}
INT callback3(INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8)
{return template(3, p1, p2, p3, p4, p5, p6, p7, p8);}
INT callback4(INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8)
{return template(4, p1, p2, p3, p4, p5, p6, p7, p8);}
INT callback5(INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8)
{return template(5, p1, p2, p3, p4, p5, p6, p7, p8);}
INT callback6(INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8)
{return template(6, p1, p2, p3, p4, p5, p6, p7, p8);}
INT callback7(INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8)
{return template(7, p1, p2, p3, p4, p5, p6, p7, p8);}
INT callback8(INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8)
{return template(8, p1, p2, p3, p4, p5, p6, p7, p8);}
INT callback9(INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8)
{return template(9, p1, p2, p3, p4, p5, p6, p7, p8);}
INT callback10(INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8)
{return template(10, p1, p2, p3, p4, p5, p6, p7, p8);}
INT callback11(INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8)
{return template(11, p1, p2, p3, p4, p5, p6, p7, p8);}
INT callback12(INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8)
{return template(12, p1, p2, p3, p4, p5, p6, p7, p8);}
INT callback13(INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8)
{return template(13, p1, p2, p3, p4, p5, p6, p7, p8);}
INT callback14(INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8)
{return template(14, p1, p2, p3, p4, p5, p6, p7, p8);}
INT callback15(INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8)
{return template(15, p1, p2, p3, p4, p5, p6, p7, p8);}
typedef INT (*lib_callback_t)(INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8);
typedef struct {
SYMBOL * sym;
lib_callback_t func;
} LIBCALLBACK;
LIBCALLBACK callback[] = {
{ NULL, callback0 },
{ NULL, callback1 },
{ NULL, callback2 },
{ NULL, callback3 },
{ NULL, callback4 },
{ NULL, callback5 },
{ NULL, callback6 },
{ NULL, callback7 },
{ NULL, callback8 },
{ NULL, callback9 },
{ NULL, callback10 },
{ NULL, callback11 },
{ NULL, callback12 },
{ NULL, callback13 },
{ NULL, callback14 },
{ NULL, callback15 },
};
INT template(INT n, INT p1, INT p2, INT p3, INT p4, INT p5, INT p6, INT p7, INT p8)
{
CELL * args;
CELL * cell;
INT result;
jmp_buf errorJumpSave;
memcpy(errorJumpSave, errorJump, sizeof(errorJump));
if(setjmp(errorJump))
{
reset();
initStacks();
result = -1;
goto FINISH_CALLBACK;
}
args = stuffIntegerList(8, p1, p2, p3, p4, p5, p6, p7, p8);
executeSymbol(callback[n].sym, (CELL *)args->contents, &cell);
#ifndef NEWLISP64
if(cell->type == CELL_INT64)
result = *(INT64 *)&cell->aux;
else
#endif
result = (INT)cell->contents;
args->contents = (UINT)nilCell;
deleteList(args);
/* before 10.4.4 this was pushResult(cell) but caused resultStack overflow
in 10.4.4 changed to deleteList(cell), but now return value on
simple callback not available anymore, use callback with libffi instead
available on -DFFI compiled versions. See also:
qa-specific-tests/qa-simplecallback
*/
deleteList(cell);
FINISH_CALLBACK:
memcpy(errorJump, errorJumpSave, sizeof(errorJump));
return(result);
}
CELL * p_callback(CELL * params)
{
CELL * cell;
SYMBOL * sPtr;
UINT n;
#ifdef FFI
SYMBOL * symbol;
CELL * ffiCell;
FFIMPORT *ffi;
char * cb_name;
int result, len;
#ifdef MAC_OSX
ffi_closure *closure;
#endif
#endif /* FFI */
cell = evaluateExpression(params);
if(cell->type == CELL_SYMBOL)
sPtr = (SYMBOL *)cell->contents;
else
goto CALLBACK_SIMPLE;
#ifdef FFI
len = strlen(sPtr->name);
cb_name = calloc(sizeof(char) * (len + 6), 1);
/*
strncpy(cb_name, "$ffi-", 6);
strncat(cb_name, sPtr->name, len);
*/
memcpy(cb_name, "$ffi-", 5);
memcpy(cb_name + 5, sPtr->name, len + 1);
symbol = translateCreateSymbol(cb_name, CELL_NIL, mainContext, TRUE);
if(isFFIsymbol(symbol->flags)) /* already defined */
{
ffiCell = (CELL *)symbol->contents;
ffi = (FFIMPORT *) ffiCell->aux;
return(stuffInteger((UINT) ffi->code));
}
if(isProtected(symbol->flags))
return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
symbol->flags |= SYMBOL_FFI | SYMBOL_PROTECTED;
if(params->next == nilCell)
return(errorProcExt(ERR_FFI_PREP_FAILED,nilCell));
ffiCell = getCell(CELL_IMPORT_FFI);
ffiCell->aux = (UINT)calloc(sizeof(FFIMPORT), 1);
((FFIMPORT *)ffiCell->aux)->name = cb_name;
ffiCell = ffiPreparation(ffiCell,params->next,FFI_CLOSURE);
if(ffiCell != nilCell)
{
ffi = (FFIMPORT *) ffiCell->aux;
ffi->data = calloc(sizeof(ffi_closure_data), 1);
#ifndef MAC_OSX
ffi->clos = ffi_closure_alloc(sizeof(ffi_closure),&ffi->code);
if(!ffi->clos)
{
free(ffi->data);
return(errorProcExt(ERR_FFI_PREP_FAILED,nilCell));
}
result = ffi_prep_closure_loc(ffi->clos, &ffi->cif, ffi_trampoline, ffi->data, ffi->code);
if(result != FFI_OK)
{
free(ffi->data);
return(errorProcExt(ERR_FFI_PREP_FAILED, stuffSymbol(sPtr)));
}
#else /* MAC_OSX */
if((closure = mmap(NULL, sizeof(ffi_closure), PROT_READ | PROT_WRITE,
MAP_ANON | MAP_PRIVATE, -1, 0)) == (void*)-1)
{
free(ffi->data);
return(errorProcExt(ERR_FFI_PREP_FAILED, stuffSymbol(sPtr)));
}
ffi->clos = closure;
if((result = ffi_prep_closure(closure, &ffi->cif, ffi_trampoline, ffi->data)) != FFI_OK)
{
free(ffi->data);
munmap(closure, sizeof(closure));
return(errorProcExt(ERR_FFI_PREP_FAILED, stuffSymbol(sPtr)));
}
if(mprotect(closure, sizeof(closure), PROT_READ | PROT_EXEC) == -1)
{
free(ffi->data);
munmap(closure, sizeof(closure));
return(errorProcExt(ERR_FFI_PREP_FAILED, stuffSymbol(sPtr)));
}
/* ffi->code = ffi_trampoline; */
ffi->code = closure;
#endif
ffi->data->symbol = sPtr;
ffi->data->code = ffi->code;
deleteList((CELL *)symbol->contents);
symbol->contents = (UINT)ffiCell;
return(stuffInteger((UINT) ffi->code));
}
else
return(errorProcExt(ERR_FFI_PREP_FAILED, stuffString(sPtr->name)));
#endif /* FFI */
CALLBACK_SIMPLE:
getIntegerExt(cell, &n, FALSE);
if(n > 15) return(errorProc(ERR_NUMBER_OUT_OF_RANGE));
getSymbol(params->next, &sPtr);
callback[n].sym = sPtr;
return(stuffInteger((UINT)callback[n].func));
}
/* ========================= FFFI using ffilib ========================== */
/* because of the non-standard cell in FFI symbol->contents, it cannot be
memory managed in an efficient way. This is why FFI functions and structs
can only be defined once. A repeated definitions will return nil and leave
the symbol's original definition untouched.
Thanks to Stefan Sonnenberg for doing most of the coding in this section.
*/
#ifdef FFI
typedef struct
{
char * name;
ffi_type * type;
int size;
} FFITYPE;
/* of the native C-types only types, which are the same
on LP64, LLP64 and ILP32, are supported
*/
/* custom ffi_type_charpointer see initFFI() */
ffi_type ffi_type_charpointer = {0, 0, 0, NULL};
FFITYPE ffi_types[] =
{
{"void", &ffi_type_void},
{"char", &ffi_type_sint8},
{"byte", &ffi_type_uint8},
{"unsigned short int", &ffi_type_uint16},
{"short int", &ffi_type_sint16},
{"unsigned int",&ffi_type_uint32},
{"int", &ffi_type_sint32},
#ifdef NEWLISP64
{"long", &ffi_type_sint64},
#else
{"long", &ffi_type_sint32},
#endif
{"long long", &ffi_type_sint64},
{"float", &ffi_type_float},
{"double", &ffi_type_double},
{"char*", &ffi_type_charpointer}, /* zero terminated string buffers with textual info */
{"void*", &ffi_type_pointer}, /* string or address with binary info, address return */
{NULL, NULL}
};
void initFFI(void)
{
memcpy(&ffi_type_charpointer, &ffi_type_pointer, sizeof(ffi_type));
}
/* creates ffi usable struct information */
CELL * p_struct(CELL * params)
{
CELL * ffiCell;
SYMBOL * symbol;
FFIMPORT * ffi;
int i;
params = getSymbol(params, &symbol);
if(isFFIsymbol(symbol->flags)) /* don't redefine */
return(stuffSymbol(symbol));
if(isProtected(symbol->flags))
return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
if(params == nilCell)
return(errorProc(ERR_MISSING_ARGUMENT));
symbol->flags |= SYMBOL_FFI | SYMBOL_PROTECTED;
ffiCell = getCell(CELL_IMPORT_FFI);
ffiCell->aux = (UINT)calloc(sizeof(FFIMPORT), 1);
ffi = (FFIMPORT *) ffiCell->aux;
ffi->name = symbol->name;
ffiCell = ffiPreparation(ffiCell, params, FFI_STRUCT);
ffi->cstruct = calloc(sizeof(ffi_type),1);
ffi->cstruct->elements = calloc(sizeof(ffi_type *) * (ffi->cif.nargs + 1), 1);
for(i = 0; i < ffi->cif.nargs; i++)
ffi->cstruct->elements[i] = ffi->cif.arg_types[i];
/* last elements[nargs] must be left 0, NULL */
/* size and alignment are already 0, to let ffi know, it has to calculate */
ffi->cstruct->type = FFI_TYPE_STRUCT;
if(ffi_prep_cif(&ffi->cif, FFI_DEFAULT_ABI, 0, ffi->cstruct, 0) != FFI_OK)
return(errorProc(ERR_FFI_PREP_FAILED));
deleteList((CELL *)symbol->contents);
symbol->contents = (UINT)ffiCell;
return(stuffSymbol(symbol));
}
CELL * packFFIstruct(CELL * cell, CELL * params)
{
char chrV;
unsigned char byteV;
short int shortV;
unsigned short int uint16V; /* 16 bit */
unsigned int uint32V; /* 32 bit */
int int32V; /* 32 bit */
unsigned long long uint64V; /* 64 bit */
float floatV;
double doubleV;
ffi_type ** elements;
ffi_type *elem;
size_t offset = 0;
unsigned short pad;
char * data;
int listFlag = 0;
FFIMPORT * ffi;
ffi = (FFIMPORT *) cell->aux;
if(ffi->cstruct && ffi->cstruct->type != FFI_TYPE_STRUCT)
return(errorProc(ERR_FFI_STRUCT_EXPECTED));
elements = (ffi_type **) ffi->cstruct->elements;
data = allocMemory(ffi->cstruct->size + 1);
memset(data, 0, ffi->cstruct->size + 1);
/* check if data come in as a list like in traditional pack */
/* computing offsets and copy data */
elements = (ffi_type **) ffi->cstruct->elements;
while( (elem = *elements++) != NULL)
{
if(params->type == CELL_NIL) break;
if(listFlag)
cell = params;
else
cell = evaluateExpression(params);
/* accept data in a list */
if(isList(cell->type))
{
params = cell = (CELL *)cell->contents;
listFlag = 1;
}
/* aligned ? */
pad = offset % elem->alignment;
/* no, add size of alignment boundary - padding bytes */
if (pad != 0) offset += elem->alignment - pad;
#ifndef NEWLISP64
if(cell->type == CELL_FLOAT || cell->type == CELL_INT64)
uint64V = *(INT64 *)&cell->aux;
else /* CELL_LONG and CELL_STRING */
uint64V = cell->contents;
#else
uint64V = cell->contents;
#endif
if( elem == &ffi_type_sint8 )
{
chrV = (char)uint64V;
memcpy(data + offset, &chrV, sizeof(char));
}
else if( elem == &ffi_type_uint8)
{
byteV = (char)uint64V;
memcpy(data + offset, &byteV, sizeof(unsigned char));
}
else if( elem == &ffi_type_uint16)
{
uint16V = (unsigned short int)uint64V;
memcpy(data + offset, &uint16V, sizeof(unsigned short int));
}
else if( elem == &ffi_type_sint16)
{
shortV = (short int)uint64V;
memcpy(data + offset, &shortV, sizeof(short int));
}
else if( elem == &ffi_type_uint32)
{
uint32V = (unsigned int)uint64V;
memcpy(data + offset, &uint32V, sizeof(unsigned int));
}
else if(elem == &ffi_type_sint32)
{
int32V = (int)uint64V;
memcpy(data + offset, &int32V, sizeof(int));
}
else if(elem == &ffi_type_sint64)
memcpy(data + offset, &uint64V, sizeof(long long));
else if(elem == &ffi_type_float)
{
floatV = (float) *(double *)&cell->aux;
memcpy(data + offset, &floatV, sizeof(float));
}
else if(elem == &ffi_type_double)
{
doubleV = getDirectFloat(cell);
memcpy(data+offset, &doubleV, sizeof(double));
}
else if(elem == &ffi_type_pointer || elem == &ffi_type_charpointer)
memcpy(data + offset, (void *)&cell->contents, sizeof(void *));
else /* just copy what's there, must be struct */
memcpy(data + offset, (void *)cell->contents, elem->size);
/* grow offset by size of last element */
offset += elem->size;
/* go to next param and repeat */
params = params->next;
}
cell = makeStringCell(data, ffi->cstruct->size);
return(cell);
}
CELL * unpackFFIstruct(CELL * cell, char * data)
{
FFIMPORT * ffi;
ffi = (FFIMPORT *) cell->aux;
if(ffi->cstruct && ffi->cstruct->type != FFI_TYPE_STRUCT)
return(errorProc(ERR_FFI_STRUCT_EXPECTED));
/* This is redundant? works with or without it on OSX, Windows, Linux.
if(ffi->cstruct->size != 0)
if(ffi_prep_cif(&ffi->cif, FFI_DEFAULT_ABI, 0, ffi->cstruct,0) != FFI_OK)
return(errorProc(ERR_FFI_PREP_FAILED));
*/
return(unpackFFI(ffi->cstruct, data));
}
CELL * unpackFFI(ffi_type * ffiPtr, char * data)
{
ffi_type * elem;
ffi_type ** elements;
CELL * cell;
size_t offset = 0;
unsigned short pad;
cell = getCell(CELL_EXPRESSION);
elements = ffiPtr->elements;
while( (elem = *elements++) != NULL )
{
pad = offset % elem->alignment;
if (pad != 0) offset += elem->alignment - pad;
addList(cell, (CELL *) ffiTypeToCell(elem, data + offset));
offset += elem->size;
}
return(cell);
}
ffi_type * getFFIType(char * type)
{
int i = 0;
char * name;
SYMBOL * sPtr;
CELL * sType;
FFIMPORT * tmp;
while((name = ffi_types[i].name))
{
if(strcmp(name, type) == 0)
return(ffi_types[i].type);
++i;
}
/* ok - no primitive type found: try to lookup struct definition */
sPtr = lookupSymbol(type,currentContext);
if(sPtr)
{
sType = (CELL *)sPtr->contents;
tmp = (FFIMPORT *)sType->aux;
return( (ffi_type *)tmp->cstruct );
}
errorProcExt2(ERR_FFI_INVALID_TYPE, stuffString(type) );
return(NULL);
}
#define MAX_TYPE_ARGS 32
CELL * ffiPreparation(CELL * pCell, CELL * params, int type)
{
CELL * arg;
FFIMPORT * ffi;
ffi_type **atypes;
unsigned int nargs;
ffi_type *rtype;
if(pCell->type != CELL_IMPORT_FFI)
errorProcExt(ERR_INVALID_PARAMETER, pCell);
ffi = (FFIMPORT *)pCell->aux;
ffi->func = FFI_FN(pCell->contents);
ffi->type = type;
atypes = calloc(sizeof(ffi_type) * MAX_TYPE_ARGS, 1);
rtype = &ffi_type_void;
/* get return type if not a structure */
if(type != FFI_STRUCT)
{
arg = evaluateExpression(params);
if(arg->type == CELL_STRING)
rtype = getFFIType((char *) arg->contents);
else
errorProcExt(ERR_STRING_EXPECTED, arg);
params = params->next;
}
nargs=0;
while((arg = evaluateExpression(params)) != nilCell)
{
if(arg->type == CELL_STRING)
{
/* skip void arguments */
if(strcmp((char *)arg->contents,"void") != 0)
{
atypes[nargs] = getFFIType((char *) arg->contents);
nargs++;
}
}
else
errorProcExt(ERR_INVALID_PARAMETER,pCell);
params = params->next;
if(nargs == MAX_TYPE_ARGS)
break;
}
ffi->cif.nargs = nargs;
ffi->cif.arg_types = atypes;
if(ffi_prep_cif(&ffi->cif, FFI_DEFAULT_ABI, nargs, rtype, atypes) != FFI_OK)
errorProcExt(ERR_FFI_PREP_FAILED, pCell);
return(pCell);
}
CELL * executeLibFFI(CELL * pCell, CELL * params)
{
FFIMPORT * ffi;
int c = 0;
ffi_type * ffiType;
INT64 value64;
UINT value;
void **avalues;
CELL * cell;
void * result;
double valueDouble;
ffi = (FFIMPORT *)pCell->aux;
if(ffi->type == FFI_STRUCT)
return(pCell);
avalues = alloca(sizeof(void *) * 16);
while(params != nilCell)
{
if(c >= ffi->cif.nargs) /* too much args */
errorProc(ERR_NUM_ARGS);
ffiType = ffi->cif.arg_types[c];
if(ffiType != &ffi_type_void)
avalues[c] = alloca(ffiType->size);
/* printf("c: %d size:%ld\n", c, ffiType->size); */
if(ffiType->type == FFI_TYPE_STRUCT)
{
cell = evaluateExpression(params);
if(cell->type == CELL_STRING)
memcpy(avalues[c],(void*) cell->contents,ffiType->size);
else
{
getIntegerExt(cell, (UINT *) &value, FALSE);
memcpy(avalues[c], (void **) value, ffiType->size);
}
params = params->next;
}
else if(ffiType == &ffi_type_pointer) /* "void*" */
{
cell = evaluateExpression(params);
if(cell->type == CELL_STRING)
*(UINT *)avalues[c] = cell->contents;
else
getIntegerExt(cell, avalues[c], FALSE);
params = params->next;
}
else if(ffiType == &ffi_type_charpointer) /* "char*" */
{
params = getString(params, avalues[c]);
}
else if(ffiType == &ffi_type_float) /* float 64-bit */
{
params = getFloat(params, &valueDouble);
*(float *)avalues[c] = valueDouble;
}
else if(ffiType == &ffi_type_double) /* double 64-bit */
params = getFloat(params, avalues[c]);
else if(ffiType == &ffi_type_sint64
|| ffiType == &ffi_type_uint64) /* int 64-bit unsiged 64-bit in newLISP */
{
params = getInteger64Ext(params, &value64, TRUE);
avalues[c] = alloca(sizeof(INT64));
*(INT64 *)avalues[c] = value64;
}
else
{
params = getInteger(params, &value);
if(ffiType == &ffi_type_sint8) /* char 8-bit */
*(char *)avalues[c] = value;
else if(ffiType == &ffi_type_uint8) /* unsigned char 8-bit */
*(unsigned char *)avalues[c] = value;
else if(ffiType == &ffi_type_sint16) /* short int 16-bit */
*(short int *)avalues[c] = value;
else if(ffiType == &ffi_type_uint16) /* unsigned short int 16-bit */
*(unsigned short int *)avalues[c] = value;
else if(ffiType == &ffi_type_sint32) /* int 32-bit */
*(int *)avalues[c] = value;
else if(ffiType == &ffi_type_uint32) /* unsigned int 32-bit */
*(unsigned int *)avalues[c] = value;
}
c++;
}
if(c < ffi->cif.nargs) /* not enough args */
errorProc(ERR_NUM_ARGS);
result = (ffi_type *) alloca(sizeof(ffi->cif.rtype->size));
ffi_call(&ffi->cif, FFI_FN(pCell->contents), result, avalues);
return ffiTypeToCell(ffi->cif.rtype, result);
}
CELL * ffiTypeToCell(ffi_type *type, void * result)
{
double valueDouble;
char * cPtr;
/* returning a structure */
if(type->type == FFI_TYPE_STRUCT)
return(unpackFFI(type, result));
/*
return stuffStringN(result, type->size);
*/
/* for C displayable strings use return type "char*"
for destructuring pointers to binary info
use "void*" as return type */
else if(type == &ffi_type_charpointer)
{
cPtr = *(char **)result;
if(cPtr == NULL)
errorProc(ERR_CANNOT_CONVERT_NULL);
return stuffString(cPtr);
}
else if(type == &ffi_type_pointer)
return stuffInteger(*((UINT *)result));
else if(type == &ffi_type_double)
return stuffFloat(*(double *)result);
else if(type == &ffi_type_float)
{
valueDouble = *(float *)result;
return stuffFloat(valueDouble);
}
else if(type == &ffi_type_sint8)
return stuffInteger(*((char *)result));
else if(type == &ffi_type_uint8)
return stuffInteger(*((unsigned char *)result));
else if(type == &ffi_type_sint16)
return stuffInteger(*((short int *)result));
else if(type == &ffi_type_uint16)
return stuffInteger(*((unsigned short int *)result));
else if(type == &ffi_type_sint32)
return stuffInteger(*((int *)result));
else if(type == &ffi_type_uint32)
return stuffInteger64(*((unsigned int *)result));
else if(type == &ffi_type_sint64 || type == &ffi_type_uint64)
return stuffInteger64(*((INT64 *)result));
return nilCell;
}
/* This function gets called by external C functions/libraries */
void ffi_trampoline(ffi_cif *cif, void *ret, void **args, void *data)
{
SYMBOL *symbol;
CELL *arg = NULL;
CELL *next;
CELL *result;
int c;
INT64 value64;
UINT value;
if(!cif)
return;
if(ret)
memset(ret, 0, cif->rtype->size);
symbol = (SYMBOL *) ((ffi_closure_data*) data)->symbol;
if(!symbol)
return;
if(cif->nargs)
{
arg = next = ffiTypeToCell(cif->arg_types[0], args[0]);
for(c = 1;c < cif->nargs; c++)
next = next->next = ffiTypeToCell(cif->arg_types[c], args[c]);
}
executeSymbol(symbol,(CELL *) arg, &result);
if((cif->rtype == &ffi_type_pointer) || (cif->rtype->type == FFI_TYPE_STRUCT) ) /* string or void pointer, or struct */
*(UINT *) ret = (UINT) result->contents;
else if(cif->rtype == &ffi_type_float) /* float 64-bit */
*(float *)ret = (float) getDirectFloat(result);
else if(cif->rtype == &ffi_type_double) /* double 64-bit */
*(double *)ret = getDirectFloat(result);
/* int 64-bit in newLISP */
else if(cif->rtype == &ffi_type_sint64 || cif->rtype == &ffi_type_uint64)
{
getInteger64Ext(result, &value64, TRUE);
*(INT64 *)ret = value64;
}
else if(cif->rtype == &ffi_type_void)
goto TRAMPOLINE_FINISH;
else
{
getIntegerExt(result, &value, FALSE);
if(cif->rtype == &ffi_type_sint8) /* char 8-bit */
*(char *)ret = (char) value;
else if(cif->rtype == &ffi_type_uint8) /* unsigned char 8-bit */
*(unsigned char *)ret = (unsigned char) value;
else if(cif->rtype == &ffi_type_sint16) /* short int 16-bit */
*(short int *)ret = (short int) value;
else if(cif->rtype == &ffi_type_uint16) /* unsigned short int 16-bit */
*(unsigned short int *)ret = (unsigned short int) value;
else if(cif->rtype == &ffi_type_sint32) /* int 32-bit */
*(int *)ret = (int) value;
else if(cif->rtype == &ffi_type_uint32) /* unsigned int 32-bit */
*(unsigned int *)ret = (unsigned int) value;
else
*(double *)ret = sqrt(-1.0); /* return NaN; never happens */
}
TRAMPOLINE_FINISH:
deleteList(result);
return;
}
#endif /* FFI */
/* end of file */
Reference in New Issue View Git Blame Copy Permalink