suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
c49b22fa2c
racket/src/foreign/foreign.c

3049 lines
109 KiB
C
Raw Blame History

/********************************************
** Do not edit this file!
** This file is generated from foreign.ssc,
** to make changes, edit that file and
** run it to generate an updated version
** of this file.
********************************************/
#include "schpriv.h"
#ifndef WINDOWS_DYNAMIC_LOAD
# include <dlfcn.h>
# if SIZEOF_CHAR == 1
typedef signed char Tsint8;
typedef unsigned char Tuint8;
# else
# error "configuration error, please contact PLT (int8)"
# endif
# if SIZEOF_SHORT == 2
typedef signed short Tsint16;
typedef unsigned short Tuint16;
# elif SIZEOF_INT == 2
typedef signed int Tsint16;
typedef unsigned int Tuint16;
# else
# error "configuration error, please contact PLT (int16)"
# endif
# if SIZEOF_INT == 4
typedef signed int Tsint32;
typedef unsigned int Tuint32;
# elif SIZEOF_LONG == 4
typedef signed long Tsint32;
typedef unsigned long Tuint32;
# else
# error "configuration error, please contact PLT (int32)"
# endif
# if SIZEOF_LONG == 8
typedef signed long Tsint64;
typedef unsigned long Tuint64;
# elif SIZEOF_LONG_LONG == 8
typedef signed long long Tsint64;
typedef unsigned long long Tuint64;
# else
# error "configuration error, please contact PLT (int64)"
# endif
#else /* WINDOWS_DYNAMIC_LOAD defined */
# include <windows.h>
# ifndef __CYGWIN32__
# include <wtypes.h>
typedef _int8 Tsint8;
typedef unsigned _int8 Tuint8;
typedef _int16 Tsint16;
typedef unsigned _int16 Tuint16;
typedef _int32 Tsint32;
typedef unsigned _int32 Tuint32;
typedef _int64 Tsint64;
typedef unsigned _int64 Tuint64;
# endif
#endif /* WINDOWS_DYNAMIC_LOAD */
#include "ffi.h"
#ifndef MZ_PRECISE_GC
# define XFORM_OK_PLUS +
# define GC_CAN_IGNORE /* empty */
#endif
#define W_OFFSET(src, delta) ((char *)(src) XFORM_OK_PLUS (delta))
/* same as the macro in file.c */
#define TO_PATH(x) (SCHEME_PATHP(x) ? (x) : scheme_char_string_to_path(x))
/*****************************************************************************/
/* Defining EnumProcessModules for openning `self' as an ffi-lib */
/* We'd like to use EnumProcessModules to find all loaded DLLs, but it's
only available in NT 4.0 and later. The alternative, Module32{First,Next},
is available *except* for NT 4.0! So we try EnumProcessModules first. */
#ifdef WINDOWS_DYNAMIC_LOAD
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
#endif
int epm_tried = 0;
typedef BOOL (WINAPI *EnumProcessModules_t)(HANDLE hProcess,
HMODULE* lphModule,
DWORD cb,
LPDWORD lpcbNeeded);
EnumProcessModules_t _EnumProcessModules;
#include <tlhelp32.h>
BOOL mzEnumProcessModules(HANDLE hProcess, HMODULE* lphModule,
DWORD cb, LPDWORD lpcbNeeded)
{
if (!epm_tried) {
HMODULE hm;
hm = LoadLibrary("psapi.dll");
if (hm) {
_EnumProcessModules =
(EnumProcessModules_t)GetProcAddress(hm, "EnumProcessModules");
}
epm_tried = 1;
}
if (_EnumProcessModules)
return _EnumProcessModules(hProcess, lphModule, cb, lpcbNeeded);
else {
HANDLE snapshot;
MODULEENTRY32 mod;
int i, ok;
snapshot = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE,
GetCurrentProcessId());
if (snapshot == INVALID_HANDLE_VALUE)
return FALSE;
for (i = 0; 1; i++) {
mod.dwSize = sizeof(mod);
if (!i)
ok = Module32First(snapshot, &mod);
else
ok = Module32Next(snapshot, &mod);
if (!ok)
break;
if (cb >= sizeof(HMODULE)) {
lphModule[i] = mod.hModule;
cb -= sizeof(HMODULE);
}
}
CloseHandle(snapshot);
*lpcbNeeded = i * sizeof(HMODULE);
return GetLastError() == ERROR_NO_MORE_FILES;
}
}
#ifdef MZ_PRECISE_GC
END_XFORM_SKIP;
#endif
#endif /* WINDOWS_DYNAMIC_LOAD */
/*****************************************************************************/
/* Library objects */
/* ffi-lib structure definition */
static Scheme_Type ffi_lib_tag;
typedef struct ffi_lib_struct {
Scheme_Object so;
void* handle;
Scheme_Object* name;
Scheme_Hash_Table* objects;
} ffi_lib_struct;
#define SCHEME_FFILIBP(x) (SCHEME_TYPE(x)==ffi_lib_tag)
#define MYNAME "ffi-lib?"
static Scheme_Object *foreign_ffi_lib_p(int argc, Scheme_Object *argv[])
{
return SCHEME_FFILIBP(argv[0]) ? scheme_true : scheme_false;
}
#undef MYNAME
/* 3m stuff for ffi_lib */
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
int ffi_lib_SIZE(void *p) {
return gcBYTES_TO_WORDS(sizeof(ffi_lib_struct));
}
int ffi_lib_MARK(void *p) {
ffi_lib_struct *s = (ffi_lib_struct *)p;
gcMARK(s->handle);
gcMARK(s->name);
gcMARK(s->objects);
return gcBYTES_TO_WORDS(sizeof(ffi_lib_struct));
}
int ffi_lib_FIXUP(void *p) {
ffi_lib_struct *s = (ffi_lib_struct *)p;
gcFIXUP(s->handle);
gcFIXUP(s->name);
gcFIXUP(s->objects);
return gcBYTES_TO_WORDS(sizeof(ffi_lib_struct));
}
END_XFORM_SKIP;
#endif
static Scheme_Hash_Table *opened_libs;
/* (ffi-lib filename no-error?) -> ffi-lib */
#define MYNAME "ffi-lib"
static Scheme_Object *foreign_ffi_lib(int argc, Scheme_Object *argv[])
{
char *name;
Scheme_Object *path, *hashname;
void *handle;
int null_ok = 0;
ffi_lib_struct *lib;
if (!(SCHEME_PATH_STRINGP(argv[0]) || SCHEME_FALSEP(argv[0])))
scheme_wrong_type(MYNAME, "string-or-false", 0, argc, argv);
/* leave the filename as given, the system will look for it */
/* (`#f' means open the executable) */
path = SCHEME_FALSEP(argv[0]) ? NULL : TO_PATH(argv[0]);
name = (path==NULL) ? NULL : SCHEME_PATH_VAL(path);
hashname = (Scheme_Object*)((name==NULL) ? "" : name);
lib = (ffi_lib_struct*)scheme_hash_get(opened_libs, hashname);
if (!lib) {
Scheme_Hash_Table *ht;
# ifdef WINDOWS_DYNAMIC_LOAD
if (name==NULL) {
/* openning the executable is marked by a NULL handle */
handle = NULL;
null_ok = 1;
} else
handle = LoadLibrary(name);
# else /* WINDOWS_DYNAMIC_LOAD undefined */
handle = dlopen(name, RTLD_NOW | RTLD_GLOBAL);
# endif /* WINDOWS_DYNAMIC_LOAD */
if (handle == NULL && !null_ok) {
if (argc > 1 && SCHEME_TRUEP(argv[1])) return scheme_false;
else {
# ifdef WINDOWS_DYNAMIC_LOAD
long err;
err = GetLastError();
scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
MYNAME": couldn't open %V (%E)", argv[0], err);
# else /* WINDOWS_DYNAMIC_LOAD undefined */
scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
MYNAME": couldn't open %V (%s)", argv[0], dlerror());
# endif /* WINDOWS_DYNAMIC_LOAD */
}
}
ht = scheme_make_hash_table(SCHEME_hash_string);
lib = (ffi_lib_struct*)scheme_malloc_tagged(sizeof(ffi_lib_struct));
lib->so.type = ffi_lib_tag;
lib->handle = (handle);
lib->name = (argv[0]);
lib->objects = (ht);
scheme_hash_set(opened_libs, hashname, (Scheme_Object*)lib);
/* no dlclose finalizer - since the hash table always keeps a reference */
/* maybe add some explicit unload at some point */
}
return (Scheme_Object*)lib;
}
#undef MYNAME
/* (ffi-lib-name ffi-lib) -> string */
#define MYNAME "ffi-lib-name"
static Scheme_Object *foreign_ffi_lib_name(int argc, Scheme_Object *argv[])
{
if (!SCHEME_FFILIBP(argv[0]))
scheme_wrong_type(MYNAME, "ffi-lib", 0, argc, argv);
return ((ffi_lib_struct*)argv[0])->name;
}
#undef MYNAME
/*****************************************************************************/
/* Pull pointers (mostly functions) out of ffi-lib objects */
/* ffi-obj structure definition */
static Scheme_Type ffi_obj_tag;
typedef struct ffi_obj_struct {
Scheme_Object so;
void* obj;
char* name;
ffi_lib_struct* lib;
} ffi_obj_struct;
#define SCHEME_FFIOBJP(x) (SCHEME_TYPE(x)==ffi_obj_tag)
#define MYNAME "ffi-obj?"
static Scheme_Object *foreign_ffi_obj_p(int argc, Scheme_Object *argv[])
{
return SCHEME_FFIOBJP(argv[0]) ? scheme_true : scheme_false;
}
#undef MYNAME
/* 3m stuff for ffi_obj */
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
int ffi_obj_SIZE(void *p) {
return gcBYTES_TO_WORDS(sizeof(ffi_obj_struct));
}
int ffi_obj_MARK(void *p) {
ffi_obj_struct *s = (ffi_obj_struct *)p;
gcMARK(s->obj);
gcMARK(s->name);
gcMARK(s->lib);
return gcBYTES_TO_WORDS(sizeof(ffi_obj_struct));
}
int ffi_obj_FIXUP(void *p) {
ffi_obj_struct *s = (ffi_obj_struct *)p;
gcFIXUP(s->obj);
gcFIXUP(s->name);
gcFIXUP(s->lib);
return gcBYTES_TO_WORDS(sizeof(ffi_obj_struct));
}
END_XFORM_SKIP;
#endif
/* (ffi-obj objname ffi-lib-or-libname) -> ffi-obj */
#define MYNAME "ffi-obj"
static Scheme_Object *foreign_ffi_obj(int argc, Scheme_Object *argv[])
{
ffi_obj_struct *obj;
void *dlobj;
ffi_lib_struct *lib = NULL;
char *dlname;
if (SCHEME_FFILIBP(argv[1]))
lib = (ffi_lib_struct*)argv[1];
else if (SCHEME_PATH_STRINGP(argv[1]) || SCHEME_FALSEP(argv[1]))
lib = (ffi_lib_struct*)(foreign_ffi_lib(1,&argv[1]));
else
scheme_wrong_type(MYNAME, "ffi-lib", 1, argc, argv);
if (!SCHEME_BYTE_STRINGP(argv[0]))
scheme_wrong_type(MYNAME, "bytes", 0, argc, argv);
dlname = SCHEME_BYTE_STR_VAL(argv[0]);
obj = (ffi_obj_struct*)scheme_hash_get(lib->objects, (Scheme_Object*)dlname);
if (!obj) {
# ifdef WINDOWS_DYNAMIC_LOAD
if (lib->handle) {
dlobj = GetProcAddress(lib->handle, dlname);
} else {
/* this is for the executable-open case, which was marked by a NULL
* handle, deal with it by searching all current modules */
# define NUM_QUICK_MODS 16
HMODULE *mods, me, quick_mods[NUM_QUICK_MODS];
DWORD cnt = NUM_QUICK_MODS * sizeof(HMODULE), actual_cnt, i;
me = GetCurrentProcess();
mods = quick_mods;
if (mzEnumProcessModules(me, mods, cnt, &actual_cnt)) {
if (actual_cnt > cnt) {
cnt = actual_cnt;
mods = (HMODULE *)scheme_malloc_atomic(cnt);
if (!mzEnumProcessModules(me, mods, cnt, &actual_cnt))
mods = NULL;
} else
cnt = actual_cnt;
} else
mods = NULL;
if (mods) {
cnt /= sizeof(HMODULE);
for (i = 0; i < cnt; i++) {
dlobj = GetProcAddress(mods[i], dlname);
if (dlobj) break;
}
} else
dlobj = NULL;
}
if (!dlobj) {
long err;
err = GetLastError();
scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
MYNAME": couldn't get \"%s\" from %V (%E)",
dlname, lib->name, err);
}
# else /* WINDOWS_DYNAMIC_LOAD undefined */
dlobj = dlsym(lib->handle, dlname);
if (!dlobj) {
const char *err;
err = dlerror();
if (err != NULL)
scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
MYNAME": couldn't get \"%s\" from %V (%s)",
dlname, lib->name, err);
}
# endif /* WINDOWS_DYNAMIC_LOAD */
obj = (ffi_obj_struct*)scheme_malloc_tagged(sizeof(ffi_obj_struct));
obj->so.type = ffi_obj_tag;
obj->obj = (dlobj);
obj->name = (dlname);
obj->lib = (lib);
scheme_hash_set(lib->objects, (Scheme_Object*)dlname, (Scheme_Object*)obj);
}
return (obj == NULL) ? scheme_false : (Scheme_Object*)obj;
}
#undef MYNAME
/* (ffi-obj-lib ffi-obj) -> ffi-lib */
#define MYNAME "ffi-obj-lib"
static Scheme_Object *foreign_ffi_obj_lib(int argc, Scheme_Object *argv[])
{
if (!SCHEME_FFIOBJP(argv[0]))
scheme_wrong_type(MYNAME, "ffi-obj", 0, argc, argv);
return (Scheme_Object*)(((ffi_obj_struct*)argv[0])->lib);
}
#undef MYNAME
/* (ffi-obj-name ffi-obj) -> string */
#define MYNAME "ffi-obj-name"
static Scheme_Object *foreign_ffi_obj_name(int argc, Scheme_Object *argv[])
{
if (!SCHEME_FFIOBJP(argv[0]))
scheme_wrong_type(MYNAME, "ffi-obj", 0, argc, argv);
return scheme_make_byte_string(((ffi_obj_struct*)argv[0])->name);
}
#undef MYNAME
/*****************************************************************************/
/* Type helpers */
/* These are not defined in MzScheme because:
* - SCHEME_UINT_VAL is not really a simple accessor like other SCHEME_X_VALs
* - scheme_make_integer_from_unsigned behaves the same as the signed version
*/
#define SCHEME_UINT_VAL(obj) ((unsigned)(SCHEME_INT_VAL(obj)))
#define scheme_make_integer_from_unsigned(i) \
((Scheme_Object *)((((unsigned long)i) << 1) | 0x1))
#ifndef SIXTY_FOUR_BIT_INTEGERS
/* longs and ints are really the same */
#define scheme_get_realint_val(x,y) \
scheme_get_int_val(x,(long*)(y))
#define scheme_get_unsigned_realint_val(x,y) \
scheme_get_unsigned_int_val(x,(unsigned long*)(y))
#define scheme_make_realinteger_value \
scheme_make_integer_value
#define scheme_make_realinteger_value_from_unsigned \
scheme_make_integer_value_from_unsigned
#else /* SIXTY_FOUR_BIT_INTEGERS defined */
/* These will make sense in MzScheme when longs are longer than ints (needed
* for libffi's int32 types). There is no need to deal with bignums because
* mzscheme's fixnums are longs. */
inline int scheme_get_realint_val(Scheme_Object *o, int *v)
{
if (SCHEME_INTP(o)) {
unsigned long lv = SCHEME_INT_VAL(o);
int i = (int)lv;
if (i != lv)
return 0;
*v = i;
return 1;
} else return 0;
}
inline int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v)
{
if (SCHEME_INTP(o)) {
unsigned long lv = SCHEME_INT_VAL(o);
unsigned int i = (unsigned int)lv;
if (i != lv)
return 0;
*v = i;
return 1;
} else return 0;
}
#define scheme_make_realinteger_value(ri) \
scheme_make_integer((long)(ri))
#define scheme_make_realinteger_value_from_unsigned(ri) \
scheme_make_integer((unsigned long)(ri))
#endif /* SIXTY_FOUR_BIT_INTEGERS */
/* This is related to the section of scheme.h that defines mzlonglong. */
#ifndef INT64_AS_LONG_LONG
#ifdef NO_LONG_LONG_TYPE
#ifndef SIXTY_FOUR_BIT_INTEGERS
#error foreign requires a 64-bit integer type type.
#endif
#endif
#endif
#define SCHEME_FALSEP_OR_CHAR_STRINGP(o) (SCHEME_FALSEP(o) || SCHEME_CHAR_STRINGP(o))
static mzchar *ucs4_string_or_null_to_ucs4_pointer(Scheme_Object *ucs)
{
if (SCHEME_FALSEP(ucs)) return NULL;
return SCHEME_CHAR_STR_VAL(ucs);
}
static unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs)
{
long ulen;
unsigned short *res;
res = scheme_ucs4_to_utf16
(SCHEME_CHAR_STR_VAL(ucs), 0, 1+SCHEME_CHAR_STRLEN_VAL(ucs),
NULL, -1, &ulen, 0);
return res;
}
static unsigned short *ucs4_string_or_null_to_utf16_pointer(Scheme_Object *ucs)
{
if (SCHEME_FALSEP(ucs)) return NULL;
return ucs4_string_to_utf16_pointer(ucs);
}
Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
{
long ulen;
mzchar *res;
int end;
if (!utf) return scheme_false;
for (end=0; utf[end] != 0; end++) { /**/ }
res = scheme_utf16_to_ucs4(utf, 0, end, NULL, -1, &ulen, 0);
return scheme_make_sized_char_string(res, ulen, 0);
}
/*****************************************************************************/
/* Types */
/***********************************************************************
* The following are the only primitive types.
* The tricky part is figuring out what width-ed types correspond to
* what internal types. Matthew says:
* MzScheme expects to be compiled such that sizeof(int) == 4,
* sizeof(long) == sizeof(void*), sizeof(short) >= 2,
* sizeof(char) == 1, sizeof(float) == 4, and sizeof(double) == 8.
* So, on a 64-bit OS, MzScheme expects only `long' to change.
**********************************************************************/
/* returns #<void> when used as output type, not for input types. */
#define FOREIGN_void (1)
/* Type Name: void
* LibFfi type: ffi_type_void
* C type: -none-
* Predicate: -none-
* Scheme->C: -none-
* S->C offset: 0
* C->Scheme: scheme_void
*/
#define FOREIGN_int8 (2)
/* Type Name: int8
* LibFfi type: ffi_type_sint8
* C type: Tsint8
* Predicate: SCHEME_INTP(<Scheme>)
* Scheme->C: SCHEME_INT_VAL(<Scheme>)
* S->C offset: 0
* C->Scheme: scheme_make_integer(<C>)
*/
#define FOREIGN_uint8 (3)
/* Type Name: uint8
* LibFfi type: ffi_type_uint8
* C type: Tuint8
* Predicate: SCHEME_INTP(<Scheme>)
* Scheme->C: SCHEME_UINT_VAL(<Scheme>)
* S->C offset: 0
* C->Scheme: scheme_make_integer_from_unsigned(<C>)
*/
#define FOREIGN_int16 (4)
/* Type Name: int16
* LibFfi type: ffi_type_sint16
* C type: Tsint16
* Predicate: SCHEME_INTP(<Scheme>)
* Scheme->C: SCHEME_INT_VAL(<Scheme>)
* S->C offset: 0
* C->Scheme: scheme_make_integer(<C>)
*/
#define FOREIGN_uint16 (5)
/* Type Name: uint16
* LibFfi type: ffi_type_uint16
* C type: Tuint16
* Predicate: SCHEME_INTP(<Scheme>)
* Scheme->C: SCHEME_UINT_VAL(<Scheme>)
* S->C offset: 0
* C->Scheme: scheme_make_integer_from_unsigned(<C>)
*/
/* Treats integers properly: */
#define FOREIGN_int32 (6)
/* Type Name: int32
* LibFfi type: ffi_type_sint32
* C type: Tsint32
* Predicate: scheme_get_realint_val(<Scheme>,&aux)
* Scheme->C: -none- (set by the predicate)
* S->C offset: 0
* C->Scheme: scheme_make_realinteger_value(<C>)
*/
/* Treats integers properly: */
#define FOREIGN_uint32 (7)
/* Type Name: uint32
* LibFfi type: ffi_type_uint32
* C type: Tuint32
* Predicate: scheme_get_unsigned_realint_val(<Scheme>,&aux)
* Scheme->C: -none- (set by the predicate)
* S->C offset: 0
* C->Scheme: scheme_make_realinteger_value_from_unsigned(<C>)
*/
#define FOREIGN_int64 (8)
/* Type Name: int64
* LibFfi type: ffi_type_sint64
* C type: Tsint64
* Predicate: scheme_get_long_long_val(<Scheme>,&aux)
* Scheme->C: -none- (set by the predicate)
* S->C offset: 0
* C->Scheme: scheme_make_integer_value_from_long_long(<C>)
*/
#define FOREIGN_uint64 (9)
/* Type Name: uint64
* LibFfi type: ffi_type_uint64
* C type: Tuint64
* Predicate: scheme_get_unsigned_long_long_val(<Scheme>,&aux)
* Scheme->C: -none- (set by the predicate)
* S->C offset: 0
* C->Scheme: scheme_make_integer_value_from_unsigned_long_long(<C>)
*/
/* This is like int32, but always assumes fixnum: */
#define FOREIGN_fixint (10)
/* Type Name: fixint
* LibFfi type: ffi_type_sint32
* C type: Tsint32
* Predicate: SCHEME_INTP(<Scheme>)
* Scheme->C: SCHEME_INT_VAL(<Scheme>)
* S->C offset: 0
* C->Scheme: scheme_make_integer(<C>)
*/
/* This is like uint32, but always assumes fixnum: */
#define FOREIGN_ufixint (11)
/* Type Name: ufixint
* LibFfi type: ffi_type_uint32
* C type: Tuint32
* Predicate: SCHEME_INTP(<Scheme>)
* Scheme->C: SCHEME_UINT_VAL(<Scheme>)
* S->C offset: 0
* C->Scheme: scheme_make_integer_from_unsigned(<C>)
*/
/* This is what mzscheme defines as long: */
#ifndef SIXTY_FOUR_BIT_INTEGERS
#define ffi_type_smzlong ffi_type_sint32
#define ffi_type_umzlong ffi_type_uint32
#else /* SIXTY_FOUR_BIT_INTEGERS defined */
#define ffi_type_smzlong ffi_type_sint64
#define ffi_type_umzlong ffi_type_uint64
#endif /* SIXTY_FOUR_BIT_INTEGERS */
/* This is what mzscheme defines as long, assuming fixnums: */
#define FOREIGN_fixnum (12)
/* Type Name: fixnum
* LibFfi type: ffi_type_smzlong
* C type: long
* Predicate: SCHEME_INTP(<Scheme>)
* Scheme->C: SCHEME_INT_VAL(<Scheme>)
* S->C offset: 0
* C->Scheme: scheme_make_integer(<C>)
*/
/* This is what mzscheme defines as ulong, assuming fixnums: */
#define FOREIGN_ufixnum (13)
/* Type Name: ufixnum
* LibFfi type: ffi_type_umzlong
* C type: unsigned long
* Predicate: SCHEME_INTP(<Scheme>)
* Scheme->C: SCHEME_UINT_VAL(<Scheme>)
* S->C offset: 0
* C->Scheme: scheme_make_integer_from_unsigned(<C>)
*/
#define FOREIGN_float (14)
/* Type Name: float
* LibFfi type: ffi_type_float
* C type: float
* Predicate: SCHEME_FLTP(<Scheme>)
* Scheme->C: SCHEME_FLT_VAL(<Scheme>)
* S->C offset: 0
* C->Scheme: scheme_make_float(<C>)
*/
#define FOREIGN_double (15)
/* Type Name: double
* LibFfi type: ffi_type_double
* C type: double
* Predicate: SCHEME_DBLP(<Scheme>)
* Scheme->C: SCHEME_DBL_VAL(<Scheme>)
* S->C offset: 0
* C->Scheme: scheme_make_double(<C>)
*/
/* A double that will coerce numbers to doubles: */
#define FOREIGN_doubleS (16)
/* Type Name: double* (doubleS)
* LibFfi type: ffi_type_double
* C type: double
* Predicate: SCHEME_REALP(<Scheme>)
* Scheme->C: scheme_real_to_double(<Scheme>)
* S->C offset: 0
* C->Scheme: scheme_make_double(<C>)
*/
/* Booleans -- implemented as an int which is 1 or 0: */
#define FOREIGN_bool (17)
/* Type Name: bool
* LibFfi type: ffi_type_sint
* C type: int
* Predicate: 1
* Scheme->C: SCHEME_TRUEP(<Scheme>)
* S->C offset: 0
* C->Scheme: (<C>?scheme_true:scheme_false)
*/
/* Strings -- no copying is done (when possible).
* #f is not NULL only for byte-strings, for other strings it is
* meaningless to use NULL. */
#define FOREIGN_string_ucs_4 (18)
/* Type Name: string/ucs-4 (string_ucs_4)
* LibFfi type: ffi_type_pointer
* C type: mzchar*
* Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>)
* Scheme->C: ucs4_string_or_null_to_ucs4_pointer(<Scheme>)
* S->C offset: 0
* C->Scheme: scheme_make_char_string_without_copying(<C>)
*/
#define FOREIGN_string_utf_16 (19)
/* Type Name: string/utf-16 (string_utf_16)
* LibFfi type: ffi_type_pointer
* C type: unsigned short*
* Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>)
* Scheme->C: ucs4_string_or_null_to_utf16_pointer(<Scheme>)
* S->C offset: 0
* C->Scheme: utf16_pointer_to_ucs4_string(<C>)
*/
/* Byte strings -- not copying C strings, #f is NULL.
* (note: these are not like char* which is just a pointer) */
#define FOREIGN_bytes (20)
/* Type Name: bytes
* LibFfi type: ffi_type_pointer
* C type: char*
* Predicate: SCHEME_FALSEP(<Scheme>)||SCHEME_BYTE_STRINGP(<Scheme>)
* Scheme->C: SCHEME_FALSEP(<Scheme>)?NULL:SCHEME_BYTE_STR_VAL(<Scheme>)
* S->C offset: 0
* C->Scheme: (<C>==NULL)?scheme_false:scheme_make_byte_string_without_copying(<C>)
*/
#define FOREIGN_path (21)
/* Type Name: path
* LibFfi type: ffi_type_pointer
* C type: char*
* Predicate: SCHEME_FALSEP(<Scheme>)||SCHEME_PATH_STRINGP(<Scheme>)
* Scheme->C: SCHEME_FALSEP(<Scheme>)?NULL:SCHEME_PATH_VAL(TO_PATH(<Scheme>))
* S->C offset: 0
* C->Scheme: (<C>==NULL)?scheme_false:scheme_make_path_without_copying(<C>)
*/
#define FOREIGN_symbol (22)
/* Type Name: symbol
* LibFfi type: ffi_type_pointer
* C type: char*
* Predicate: SCHEME_SYMBOLP(<Scheme>)
* Scheme->C: SCHEME_SYM_VAL(<Scheme>)
* S->C offset: 0
* C->Scheme: scheme_intern_symbol(<C>)
*/
/* This is for any C pointer: #f is NULL, cpointer values as well as
* ffi-obj and string values pass their pointer. When used as a return
* value, either a cpointer object or #f is returned. */
#define FOREIGN_pointer (23)
/* Type Name: pointer
* LibFfi type: ffi_type_pointer
* C type: void*
* Predicate: SCHEME_FFIANYPTRP(<Scheme>)
* Scheme->C: SCHEME_FFIANYPTR_VAL(<Scheme>)
* S->C offset: FFIANYPTR
* C->Scheme: scheme_make_foreign_external_cpointer(<C>)
*/
#define FOREIGN_gcpointer (24)
/* Type Name: gcpointer
* LibFfi type: ffi_type_gcpointer
* C type: void*
* Predicate: SCHEME_FFIANYPTRP(<Scheme>)
* Scheme->C: SCHEME_FFIANYPTR_VAL(<Scheme>)
* S->C offset: FFIANYPTR
* C->Scheme: scheme_make_foreign_cpointer(<C>)
*/
/* This is used for passing and Scheme_Object* value as is. Useful for
* functions that know about Scheme_Object*s, like MzScheme's. */
#define FOREIGN_scheme (25)
/* Type Name: scheme
* LibFfi type: ffi_type_gcpointer
* C type: Scheme_Object*
* Predicate: 1
* Scheme->C: <Scheme>
* S->C offset: 0
* C->Scheme: <C>
*/
/* Special type, not actually used for anything except to mark values
* that are treated like pointers but not referenced. Used for
* creating function types. */
#define FOREIGN_fpointer (26)
/* Type Name: fpointer
* LibFfi type: ffi_type_pointer
* C type: void*
* Predicate: -none-
* Scheme->C: -none-
* S->C offset: 0
* C->Scheme: -none-
*/
typedef union _ForeignAny {
Tsint8 x_int8;
Tuint8 x_uint8;
Tsint16 x_int16;
Tuint16 x_uint16;
Tsint32 x_int32;
Tuint32 x_uint32;
Tsint64 x_int64;
Tuint64 x_uint64;
Tsint32 x_fixint;
Tuint32 x_ufixint;
long x_fixnum;
unsigned long x_ufixnum;
float x_float;
double x_double;
double x_doubleS;
int x_bool;
mzchar* x_string_ucs_4;
unsigned short* x_string_utf_16;
char* x_bytes;
char* x_path;
char* x_symbol;
void* x_pointer;
void* x_gcpointer;
Scheme_Object* x_scheme;
void* x_fpointer;
} ForeignAny;
/* This is a tag that is used to identify user-made struct types. */
#define FOREIGN_struct (27)
/*****************************************************************************/
/* Type objects */
/* This struct is used for both user types and primitive types (including
* struct types). If it is a user type then basetype will be another ctype,
* otherwise,
* - if it's a primitive type, then basetype will be a symbol naming that type
* - if it's a struct, then basetype will be the list of ctypes that
* made this struct
* scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an
* integer (a label value) for non-struct type. (Note that the
* integer is not really needed, since it is possible to identify the
* type by the basetype field.)
*/
/* ctype structure definition */
static Scheme_Type ctype_tag;
typedef struct ctype_struct {
Scheme_Object so;
Scheme_Object* basetype;
Scheme_Object* scheme_to_c;
Scheme_Object* c_to_scheme;
} ctype_struct;
#define SCHEME_CTYPEP(x) (SCHEME_TYPE(x)==ctype_tag)
#define MYNAME "ctype?"
static Scheme_Object *foreign_ctype_p(int argc, Scheme_Object *argv[])
{
return SCHEME_CTYPEP(argv[0]) ? scheme_true : scheme_false;
}
#undef MYNAME
/* 3m stuff for ctype */
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
int ctype_SIZE(void *p) {
return gcBYTES_TO_WORDS(sizeof(ctype_struct));
}
int ctype_MARK(void *p) {
ctype_struct *s = (ctype_struct *)p;
gcMARK(s->basetype);
gcMARK(s->scheme_to_c);
gcMARK(s->c_to_scheme);
return gcBYTES_TO_WORDS(sizeof(ctype_struct));
}
int ctype_FIXUP(void *p) {
ctype_struct *s = (ctype_struct *)p;
gcFIXUP(s->basetype);
gcFIXUP(s->scheme_to_c);
gcFIXUP(s->c_to_scheme);
return gcBYTES_TO_WORDS(sizeof(ctype_struct));
}
END_XFORM_SKIP;
#endif
static ffi_type ffi_type_gcpointer;
#define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype)
#define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))
#define CTYPE_PRIMP(x) (!CTYPE_USERP(x))
#define CTYPE_PRIMTYPE(x) ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c))
#define CTYPE_PRIMLABEL(x) ((long)(((ctype_struct*)(x))->c_to_scheme))
#define CTYPE_USER_S2C(x) (((ctype_struct*)(x))->scheme_to_c)
#define CTYPE_USER_C2S(x) (((ctype_struct*)(x))->c_to_scheme)
/* Returns #f for primitive types. */
#define MYNAME "ctype-basetype"
static Scheme_Object *foreign_ctype_basetype(int argc, Scheme_Object *argv[])
{
if (!SCHEME_CTYPEP(argv[0]))
scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
return CTYPE_BASETYPE(argv[0]);
}
#undef MYNAME
#define MYNAME "ctype-scheme->c"
static Scheme_Object *foreign_ctype_scheme_to_c(int argc, Scheme_Object *argv[])
{
if (!SCHEME_CTYPEP(argv[0]))
scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
return (CTYPE_PRIMP(argv[0])) ? scheme_false :
((ctype_struct*)(argv[0]))->scheme_to_c;
}
#undef MYNAME
#define MYNAME "ctype-c->scheme"
static Scheme_Object *foreign_ctype_c_to_scheme(int argc, Scheme_Object *argv[])
{
if (!SCHEME_CTYPEP(argv[0]))
scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
return (CTYPE_PRIMP(argv[0])) ? scheme_false :
((ctype_struct*)(argv[0]))->c_to_scheme;
}
#undef MYNAME
/* Returns a primitive type, or NULL if not a type */
static Scheme_Object *get_ctype_base(Scheme_Object *type)
{
if (!SCHEME_CTYPEP(type)) return NULL;
while (CTYPE_USERP(type)) { type = CTYPE_BASETYPE(type); }
return type;
}
/* Returns the size, 0 for void, -1 if no such type */
static int ctype_sizeof(Scheme_Object *type)
{
type = get_ctype_base(type);
if (type == NULL) return -1;
switch (CTYPE_PRIMLABEL(type)) {
case FOREIGN_void: return 0;
case FOREIGN_int8: return sizeof(Tsint8);
case FOREIGN_uint8: return sizeof(Tuint8);
case FOREIGN_int16: return sizeof(Tsint16);
case FOREIGN_uint16: return sizeof(Tuint16);
case FOREIGN_int32: return sizeof(Tsint32);
case FOREIGN_uint32: return sizeof(Tuint32);
case FOREIGN_int64: return sizeof(Tsint64);
case FOREIGN_uint64: return sizeof(Tuint64);
case FOREIGN_fixint: return sizeof(Tsint32);
case FOREIGN_ufixint: return sizeof(Tuint32);
case FOREIGN_fixnum: return sizeof(long);
case FOREIGN_ufixnum: return sizeof(unsigned long);
case FOREIGN_float: return sizeof(float);
case FOREIGN_double: return sizeof(double);
case FOREIGN_doubleS: return sizeof(double);
case FOREIGN_bool: return sizeof(int);
case FOREIGN_string_ucs_4: return sizeof(mzchar*);
case FOREIGN_string_utf_16: return sizeof(unsigned short*);
case FOREIGN_bytes: return sizeof(char*);
case FOREIGN_path: return sizeof(char*);
case FOREIGN_symbol: return sizeof(char*);
case FOREIGN_pointer: return sizeof(void*);
case FOREIGN_gcpointer: return sizeof(void*);
case FOREIGN_scheme: return sizeof(Scheme_Object*);
case FOREIGN_fpointer: return sizeof(void*);
/* for structs */
default: return CTYPE_PRIMTYPE(type)->size;
}
}
/* (make-ctype basetype scheme->c c->scheme) -> ctype */
/* The scheme->c can throw type errors to check for valid arguments */
/* a #f means no conversion function, if both are #f -- then just return the */
/* basetype. */
#define MYNAME "make-ctype"
static Scheme_Object *foreign_make_ctype(int argc, Scheme_Object *argv[])
{
ctype_struct *type;
if (!SCHEME_CTYPEP(argv[0]))
scheme_wrong_type(MYNAME, "C-type", 0, argc, argv);
else if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1])))
scheme_wrong_type(MYNAME, "procedure-or-false", 1, argc, argv);
else if (!(SCHEME_FALSEP(argv[2]) || SCHEME_PROCP(argv[2])))
scheme_wrong_type(MYNAME, "procedure-or-false", 2, argc, argv);
else if (SCHEME_FALSEP(argv[1]) && SCHEME_FALSEP(argv[2]))
return argv[0];
else {
type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
type->so.type = ctype_tag;
type->basetype = (argv[0]);
type->scheme_to_c = (argv[1]);
type->c_to_scheme = (argv[2]);
return (Scheme_Object*)type;
}
return NULL; /* hush the compiler */
}
#undef MYNAME
/* see below */
void free_libffi_type(void *ignored, void *p)
{
free(((ffi_type*)p)->elements);
free(p);
}
/*****************************************************************************/
/* ABI spec */
static Scheme_Object *default_sym;
static Scheme_Object *stdcall_sym;
static Scheme_Object *sysv_sym;
ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
{
if (SCHEME_FALSEP(sym) || SAME_OBJ(sym, default_sym))
return FFI_DEFAULT_ABI;
else if (SAME_OBJ(sym, sysv_sym)) {
#ifdef WINDOWS_DYNAMIC_LOAD
return FFI_SYSV;
#else
scheme_signal_error("%s: ABI not implemented: %V", who, sym);
#endif
} else if (SAME_OBJ(sym, stdcall_sym)) {
#ifdef WINDOWS_DYNAMIC_LOAD
return FFI_STDCALL;
#else
scheme_signal_error("%s: ABI not implemented: %V", who, sym);
#endif
} else {
scheme_signal_error("%s: unknown ABI: %V", who, sym);
}
return 0; /* hush the compiler */
}
/* helper macro */
#define GET_ABI(name,n) \
((argc > (n)) ? sym_to_abi((name),argv[n]) : FFI_DEFAULT_ABI)
/*****************************************************************************/
/* cstruct types */
/* (make-cstruct-type types [abi]) -> ctype */
/* This creates a new primitive type that is a struct. This type can be used
* with cpointer objects, except that the contents is used rather than the
* pointer value. Marshaling to lists or whatever should be done in Scheme. */
#define MYNAME "make-cstruct-type"
static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
{
Scheme_Object *p, *base;
/* since ffi_type objects can be used in callbacks, they are allocated using
* malloc so they don't move, and they are freed when the Scheme object is
* GCed. */
GC_CAN_IGNORE ffi_type **elements, *libffi_type, **dummy;
ctype_struct *type;
ffi_cif cif;
int i, nargs;
ffi_abi abi;
nargs = scheme_proper_list_length(argv[0]);
if (nargs < 0) scheme_wrong_type(MYNAME, "proper list", 0, argc, argv);
abi = GET_ABI(MYNAME,1);
/* allocate the type elements */
elements = malloc((nargs+1) * sizeof(ffi_type*));
elements[nargs] = NULL;
for (i=0, p=argv[0]; i<nargs; i++, p=SCHEME_CDR(p)) {
if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
scheme_wrong_type(MYNAME, "list-of-C-types", 0, argc, argv);
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 0, argc, argv);
elements[i] = CTYPE_PRIMTYPE(base);
}
/* allocate the new libffi type object */
libffi_type = malloc(sizeof(ffi_type));
libffi_type->size = 0;
libffi_type->alignment = 0;
libffi_type->type = FFI_TYPE_STRUCT;
libffi_type->elements = elements;
/* use ffi_prep_cif to set the size and alignment information */
dummy = &libffi_type;
if (ffi_prep_cif(&cif, abi, 1, &ffi_type_void, dummy) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
type->so.type = ctype_tag;
type->basetype = (argv[0]);
type->scheme_to_c = ((Scheme_Object*)libffi_type);
type->c_to_scheme = ((Scheme_Object*)FOREIGN_struct);
scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
return (Scheme_Object*)type;
}
#undef MYNAME
/*****************************************************************************/
/* Callback type */
/* ffi-callback structure definition */
static Scheme_Type ffi_callback_tag;
typedef struct ffi_callback_struct {
Scheme_Object so;
void* callback;
Scheme_Object* proc;
Scheme_Object* itypes;
Scheme_Object* otype;
int call_in_scheduler;
} ffi_callback_struct;
#define SCHEME_FFICALLBACKP(x) (SCHEME_TYPE(x)==ffi_callback_tag)
#define MYNAME "ffi-callback?"
static Scheme_Object *foreign_ffi_callback_p(int argc, Scheme_Object *argv[])
{
return SCHEME_FFICALLBACKP(argv[0]) ? scheme_true : scheme_false;
}
#undef MYNAME
/* 3m stuff for ffi_callback */
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
int ffi_callback_SIZE(void *p) {
return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct));
}
int ffi_callback_MARK(void *p) {
ffi_callback_struct *s = (ffi_callback_struct *)p;
gcMARK(s->callback);
gcMARK(s->proc);
gcMARK(s->itypes);
gcMARK(s->otype);
return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct));
}
int ffi_callback_FIXUP(void *p) {
ffi_callback_struct *s = (ffi_callback_struct *)p;
gcFIXUP(s->callback);
gcFIXUP(s->proc);
gcFIXUP(s->itypes);
gcFIXUP(s->otype);
return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct));
}
END_XFORM_SKIP;
#endif
/*****************************************************************************/
/* Pointer objects */
/* use cpointer (with a NULL tag when creating), #f for NULL */
#define SCHEME_FFIANYPTRP(x) \
(SCHEME_FALSEP(x) || SCHEME_CPTRP(x) || SCHEME_FFIOBJP(x) || \
SCHEME_BYTE_STRINGP(x) || SCHEME_FFICALLBACKP(x))
#define SCHEME_FFIANYPTR_VAL(x) \
(SCHEME_CPTRP(x) ? SCHEME_CPTR_VAL(x) : \
(SCHEME_FALSEP(x) ? NULL : \
(SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \
(SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \
(SCHEME_FFICALLBACKP(x) ? ((ffi_callback_struct *)x)->callback : \
NULL)))))
#define SCHEME_FFIANYPTR_OFFSET(x) \
(SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0)
#define SCHEME_FFIANYPTR_OFFSETVAL(x) \
W_OFFSET(SCHEME_FFIANYPTR_VAL(x), SCHEME_FFIANYPTR_OFFSET(x))
#define SCHEME_CPOINTER_W_OFFSET_P(x) \
SAME_TYPE(SCHEME_TYPE(x), scheme_offset_cpointer_type)
#define scheme_make_foreign_cpointer(x) \
((x==NULL)?scheme_false:scheme_make_cptr(x,NULL))
#define scheme_make_foreign_external_cpointer(x) \
((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL))
#define MYNAME "cpointer?"
static Scheme_Object *foreign_cpointer_p(int argc, Scheme_Object *argv[])
{
return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false;
}
#undef MYNAME
#define MYNAME "cpointer-tag"
static Scheme_Object *foreign_cpointer_tag(int argc, Scheme_Object *argv[])
{
Scheme_Object *tag = NULL;
if (!SCHEME_FFIANYPTRP(argv[0]))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
if (SCHEME_CPTRP(argv[0])) tag = SCHEME_CPTR_TYPE(argv[0]);
return (tag == NULL) ? scheme_false : tag;
}
#undef MYNAME
#define MYNAME "set-cpointer-tag!"
static Scheme_Object *foreign_set_cpointer_tag_bang(int argc, Scheme_Object *argv[])
{
if (!SCHEME_CPTRP(argv[0]))
scheme_wrong_type(MYNAME, "proper-cpointer", 0, argc, argv);
SCHEME_CPTR_TYPE(argv[0]) = argv[1];
return scheme_void;
}
#undef MYNAME
/*****************************************************************************/
/* Scheme<-->C conversions */
/* On big endian machines we need to know whether we're pulling a value from an
* argument location where it always takes a whole word or straight from a
* memory location -- deal with it via a C2SCHEME macro wrapper that is used
* for both the function definition and calls */
#ifdef SCHEME_BIG_ENDIAN
#define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta,argsloc)
#define REF_CTYPE(ctype) (((sizeof(ctype)<sizeof(int)) && args_loc) \
? ((ctype)(((int*)W_OFFSET(src,delta))[0])) \
: (((ctype *)W_OFFSET(src,delta))[0]))
#else
#define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta)
#define REF_CTYPE(ctype) (((ctype *)W_OFFSET(src,delta))[0])
#endif
static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
int delta, int args_loc)
{
Scheme_Object *res;
if (!SCHEME_CTYPEP(type))
scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
if (CTYPE_USERP(type)) {
res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc);
if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
return res;
else
return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res));
} else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
return scheme_make_foreign_external_cpointer(*(void **)W_OFFSET(src, delta));
} else switch (CTYPE_PRIMLABEL(type)) {
case FOREIGN_void: return scheme_void;
case FOREIGN_int8: return scheme_make_integer(REF_CTYPE(Tsint8));
case FOREIGN_uint8: return scheme_make_integer_from_unsigned(REF_CTYPE(Tuint8));
case FOREIGN_int16: return scheme_make_integer(REF_CTYPE(Tsint16));
case FOREIGN_uint16: return scheme_make_integer_from_unsigned(REF_CTYPE(Tuint16));
case FOREIGN_int32: return scheme_make_realinteger_value(REF_CTYPE(Tsint32));
case FOREIGN_uint32: return scheme_make_realinteger_value_from_unsigned(REF_CTYPE(Tuint32));
case FOREIGN_int64: return scheme_make_integer_value_from_long_long(REF_CTYPE(Tsint64));
case FOREIGN_uint64: return scheme_make_integer_value_from_unsigned_long_long(REF_CTYPE(Tuint64));
case FOREIGN_fixint: return scheme_make_integer(REF_CTYPE(Tsint32));
case FOREIGN_ufixint: return scheme_make_integer_from_unsigned(REF_CTYPE(Tuint32));
case FOREIGN_fixnum: return scheme_make_integer(REF_CTYPE(long));
case FOREIGN_ufixnum: return scheme_make_integer_from_unsigned(REF_CTYPE(unsigned long));
case FOREIGN_float: return scheme_make_float(REF_CTYPE(float));
case FOREIGN_double: return scheme_make_double(REF_CTYPE(double));
case FOREIGN_doubleS: return scheme_make_double(REF_CTYPE(double));
case FOREIGN_bool: return (REF_CTYPE(int)?scheme_true:scheme_false);
case FOREIGN_string_ucs_4: return scheme_make_char_string_without_copying(REF_CTYPE(mzchar*));
case FOREIGN_string_utf_16: return utf16_pointer_to_ucs4_string(REF_CTYPE(unsigned short*));
case FOREIGN_bytes: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_byte_string_without_copying(REF_CTYPE(char*));
case FOREIGN_path: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_path_without_copying(REF_CTYPE(char*));
case FOREIGN_symbol: return scheme_intern_symbol(REF_CTYPE(char*));
case FOREIGN_pointer: return scheme_make_foreign_external_cpointer(REF_CTYPE(void*));
case FOREIGN_gcpointer: return scheme_make_foreign_cpointer(REF_CTYPE(void*));
case FOREIGN_scheme: return REF_CTYPE(Scheme_Object*);
case FOREIGN_fpointer: return (REF_CTYPE(void*));
case FOREIGN_struct:
return scheme_make_foreign_cpointer(W_OFFSET(src, delta));
default: scheme_signal_error("corrupt foreign type: %V", type);
}
return NULL; /* hush the compiler */
}
#undef REF_CTYPE
/* On big endian machines we need to know whether we're pulling a value from an
* argument location where it always takes a whole word or straight from a
* memory location -- deal with it as above, via a SCHEME2C macro wrapper that
* is used for both the function definition and calls, but the actual code in
* the function is different: in the relevant cases zero an int and offset the
* ptr */
/* Usually writes the C object to dst and returns NULL. When basetype_p is not
* NULL, then any pointer value (any pointer or a struct) is returned, and the
* basetype_p is set to the corrsponding number tag. If basetype_p is NULL,
* then a struct value will be *copied* into dst. */
static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
Scheme_Object *val, long *basetype_p, long *_offset,
int ret_loc)
{
if (!SCHEME_CTYPEP(type))
scheme_wrong_type("Scheme->C", "C-type", 0, 1, &type);
while (CTYPE_USERP(type)) {
if (!SCHEME_FALSEP(CTYPE_USER_S2C(type)))
val = _scheme_apply(CTYPE_USER_S2C(type), 1, (Scheme_Object**)(&val));
type = CTYPE_BASETYPE(type);
}
if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
/* No need for the SET_CTYPE trick for pointers. */
if (SCHEME_FFICALLBACKP(val))
((void**)W_OFFSET(dst,delta))[0] = ((ffi_callback_struct*)val)->callback;
else if (SCHEME_CPTRP(val))
((void**)W_OFFSET(dst,delta))[0] = SCHEME_CPTR_VAL(val);
else if (SCHEME_FFIOBJP(val))
((void**)W_OFFSET(dst,delta))[0] = ((ffi_obj_struct*)val)->obj;
else if (SCHEME_FALSEP(val))
((void**)W_OFFSET(dst,delta))[0] = NULL;
else /* ((void**)W_OFFSET(dst,delta))[0] = val; */
scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val);
} else switch (CTYPE_PRIMLABEL(type)) {
case FOREIGN_void:
if (!ret_loc) scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type));
break;
case FOREIGN_int8:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(Tsint8)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(Tsint8));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_INTP(val)) {
Tsint8 tmp;
tmp = (Tsint8)(SCHEME_INT_VAL(val));
(((Tsint8*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","int8",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_uint8:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(Tuint8)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(Tuint8));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_INTP(val)) {
Tuint8 tmp;
tmp = (Tuint8)(SCHEME_UINT_VAL(val));
(((Tuint8*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","uint8",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_int16:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(Tsint16)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(Tsint16));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_INTP(val)) {
Tsint16 tmp;
tmp = (Tsint16)(SCHEME_INT_VAL(val));
(((Tsint16*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","int16",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_uint16:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(Tuint16)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(Tuint16));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_INTP(val)) {
Tuint16 tmp;
tmp = (Tuint16)(SCHEME_UINT_VAL(val));
(((Tuint16*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","uint16",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_int32:
if (!(scheme_get_realint_val(val,&(((Tsint32*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","int32",0,1,&(val));
return NULL;
case FOREIGN_uint32:
if (!(scheme_get_unsigned_realint_val(val,&(((Tuint32*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","uint32",0,1,&(val));
return NULL;
case FOREIGN_int64:
if (!(scheme_get_long_long_val(val,&(((Tsint64*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","int64",0,1,&(val));
return NULL;
case FOREIGN_uint64:
if (!(scheme_get_unsigned_long_long_val(val,&(((Tuint64*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","uint64",0,1,&(val));
return NULL;
case FOREIGN_fixint:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(Tsint32)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(Tsint32));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_INTP(val)) {
Tsint32 tmp;
tmp = (Tsint32)(SCHEME_INT_VAL(val));
(((Tsint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","fixint",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_ufixint:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(Tuint32)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(Tuint32));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_INTP(val)) {
Tuint32 tmp;
tmp = (Tuint32)(SCHEME_UINT_VAL(val));
(((Tuint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","ufixint",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_fixnum:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(long)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(long));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_INTP(val)) {
long tmp;
tmp = (long)(SCHEME_INT_VAL(val));
(((long*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","fixnum",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_ufixnum:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(unsigned long)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(unsigned long));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_INTP(val)) {
unsigned long tmp;
tmp = (unsigned long)(SCHEME_UINT_VAL(val));
(((unsigned long*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","ufixnum",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_float:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(float)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(float));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_FLTP(val)) {
float tmp;
tmp = (float)(SCHEME_FLT_VAL(val));
(((float*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","float",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_double:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(double)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(double));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_DBLP(val)) {
double tmp;
tmp = (double)(SCHEME_DBL_VAL(val));
(((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","double",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_doubleS:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(double)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(double));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_REALP(val)) {
double tmp;
tmp = (double)(scheme_real_to_double(val));
(((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","double*",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_bool:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(int)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(int));
}
# endif /* SCHEME_BIG_ENDIAN */
if (1) {
int tmp;
tmp = (int)(SCHEME_TRUEP(val));
(((int*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","bool",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_string_ucs_4:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(mzchar*)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(mzchar*));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
mzchar* tmp;
tmp = (mzchar*)(ucs4_string_or_null_to_ucs4_pointer(val));
if (basetype_p == NULL || tmp == NULL) {
(((mzchar**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;
} else {
*basetype_p = FOREIGN_string_ucs_4;
return tmp;
}
} else {
scheme_wrong_type("Scheme->C","string/ucs-4",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_string_utf_16:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(unsigned short*)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(unsigned short*));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
unsigned short* tmp;
tmp = (unsigned short*)(ucs4_string_or_null_to_utf16_pointer(val));
if (basetype_p == NULL || tmp == NULL) {
(((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;
} else {
*basetype_p = FOREIGN_string_utf_16;
return tmp;
}
} else {
scheme_wrong_type("Scheme->C","string/utf-16",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_bytes:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(char*)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(char*));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_FALSEP(val)||SCHEME_BYTE_STRINGP(val)) {
char* tmp;
tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_BYTE_STR_VAL(val));
if (basetype_p == NULL || tmp == NULL) {
(((char**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;
} else {
*basetype_p = FOREIGN_bytes;
return tmp;
}
} else {
scheme_wrong_type("Scheme->C","bytes",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_path:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(char*)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(char*));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_FALSEP(val)||SCHEME_PATH_STRINGP(val)) {
char* tmp;
tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_PATH_VAL(TO_PATH(val)));
if (basetype_p == NULL || tmp == NULL) {
(((char**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;
} else {
*basetype_p = FOREIGN_path;
return tmp;
}
} else {
scheme_wrong_type("Scheme->C","path",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_symbol:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(char*)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(char*));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_SYMBOLP(val)) {
char* tmp;
tmp = (char*)(SCHEME_SYM_VAL(val));
if (basetype_p == NULL || tmp == NULL) {
(((char**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;
} else {
*basetype_p = FOREIGN_symbol;
return tmp;
}
} else {
scheme_wrong_type("Scheme->C","symbol",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_pointer:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(void*)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(void*));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_FFIANYPTRP(val)) {
void* tmp; long toff;
tmp = (void*)(SCHEME_FFIANYPTR_VAL(val));
toff = SCHEME_FFIANYPTR_OFFSET(val);
if (_offset) *_offset = toff;
if (basetype_p == NULL || (tmp == NULL && toff == 0)) {
(((void**)W_OFFSET(dst,delta))[0]) = (_offset ? tmp : (void*)W_OFFSET(tmp, toff));
return NULL;
} else {
*basetype_p = FOREIGN_pointer;
return _offset ? tmp : (void*)W_OFFSET(tmp, toff);
}
} else {
scheme_wrong_type("Scheme->C","pointer",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_gcpointer:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(void*)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(void*));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_FFIANYPTRP(val)) {
void* tmp; long toff;
tmp = (void*)(SCHEME_FFIANYPTR_VAL(val));
toff = SCHEME_FFIANYPTR_OFFSET(val);
if (_offset) *_offset = toff;
(((void**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","gcpointer",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_scheme:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(Scheme_Object*)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(Scheme_Object*));
}
# endif /* SCHEME_BIG_ENDIAN */
if (1) {
Scheme_Object* tmp;
tmp = (Scheme_Object*)(val);
(((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","scheme",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_fpointer:
if (!(ret_loc)) scheme_wrong_type("Scheme->C","fpointer",0,1,&(val));
break;
case FOREIGN_struct:
if (!SCHEME_FFIANYPTRP(val))
scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);
{
void* p = SCHEME_FFIANYPTR_VAL(val);
long poff = SCHEME_FFIANYPTR_OFFSET(val);
if (basetype_p == NULL) {
if (p == NULL && poff == 0)
scheme_signal_error("FFI pointer value was NULL");
memcpy(W_OFFSET(dst, delta), W_OFFSET(p, poff),
CTYPE_PRIMTYPE(type)->size);
return NULL;
} else {
*basetype_p = FOREIGN_struct;
if (_offset) {
*_offset = poff;
return p;
} else {
return W_OFFSET(p, poff);
}
}
}
default: scheme_signal_error("corrupt foreign type: %V", type);
}
return NULL; /* hush the compiler */
}
#undef SET_CTYPE
/*****************************************************************************/
/* C type information */
/* (ctype-sizeof type) -> int, returns 0 for void, error if not a C type */
#define MYNAME "ctype-sizeof"
static Scheme_Object *foreign_ctype_sizeof(int argc, Scheme_Object *argv[])
{
int size;
size = ctype_sizeof(argv[0]);
if (size >= 0) return scheme_make_integer(size);
else scheme_wrong_type(MYNAME, "C-type", 0, argc, argv);
return NULL; /* hush the compiler */
}
#undef MYNAME
/* (ctype-alignof type) -> int, returns 0 for void, error if not a C type */
#define MYNAME "ctype-alignof"
static Scheme_Object *foreign_ctype_alignof(int argc, Scheme_Object *argv[])
{
Scheme_Object *type;
type = get_ctype_base(argv[0]);
if (type == NULL) scheme_wrong_type(MYNAME, "C-type", 0, argc, argv);
else return scheme_make_integer(CTYPE_PRIMTYPE(type)->alignment);
return NULL; /* hush the compiler */
}
#undef MYNAME
/* (compiler-sizeof symbols) -> int, where symbols name some C type.
* The symbols are in 'int 'char 'void 'short 'long '*, order does not matter,
* when a single symbol is used, a list is not needed.
* (This is about actual C types, not C type objects.) */
#define MYNAME "compiler-sizeof"
static Scheme_Object *foreign_compiler_sizeof(int argc, Scheme_Object *argv[])
{
int res=0;
int basetype = 0; /* 1=int, 2=char, 3=void, 4=float, 5=double */
int intsize = 0; /* "short" => decrement, "long" => increment */
int stars = 0; /* number of "*"s */
Scheme_Object *l = argv[0], *p;
while (!SAME_OBJ(l, scheme_null)) {
if (SCHEME_PAIRP(l)) { p = SCHEME_CAR(l); l = SCHEME_CDR(l); }
else { p = l; l = scheme_null; }
if (!SCHEME_SYMBOLP(p)) {
scheme_wrong_type(MYNAME, "list of symbols", 0, argc, argv);
} else if (!strcmp(SCHEME_SYM_VAL(p),"int")) {
if (basetype==0) basetype=1;
else scheme_signal_error(MYNAME": extraneous type: %V", p);
} else if (!strcmp(SCHEME_SYM_VAL(p),"char")) {
if (basetype==0) basetype=2;
else scheme_signal_error(MYNAME": extraneous type: %V", p);
} else if (!strcmp(SCHEME_SYM_VAL(p),"void")) {
if (basetype==0) basetype=3;
else scheme_signal_error(MYNAME": extraneous type: %V", p);
} else if (!strcmp(SCHEME_SYM_VAL(p),"float")) {
if (basetype==0) basetype=4;
else scheme_signal_error(MYNAME": extraneous type: %V", p);
} else if (!strcmp(SCHEME_SYM_VAL(p),"double")) {
if (basetype==0 || basetype==4) basetype=5;
else scheme_signal_error(MYNAME": extraneous type: %V", p);
} else if (!strcmp(SCHEME_SYM_VAL(p),"short")) {
if (intsize>0)
scheme_signal_error(MYNAME": cannot use both 'short and 'long");
else intsize--;
} else if (!strcmp(SCHEME_SYM_VAL(p),"long")) {
if (intsize<0)
scheme_signal_error(MYNAME": cannot use both 'short and 'long");
else intsize++;
} else if (!strcmp(SCHEME_SYM_VAL(p),"*")) {
stars++;
} else {
scheme_wrong_type(MYNAME, "list of C type symbols", 0, argc, argv);
}
}
if (stars > 1)
scheme_signal_error(MYNAME": cannot handle more than one '*");
if (intsize < -1)
scheme_signal_error(MYNAME": cannot handle more than one 'short");
if (intsize > 2)
scheme_signal_error(MYNAME": cannot handle more than two 'long");
if (basetype == 0) basetype = 1; /* int is the default type */
/* don't assume anything, so it can be used to verify compiler assumptions */
/* (only forbid stuff that the compiler doesn't allow) */
# define RETSIZE(t) res=((stars==0)?sizeof(t):sizeof(t *))
switch (basetype) {
case 1: /* int */
switch (intsize) {
case 0: RETSIZE(int); break;
case 1: RETSIZE(long int); break;
# ifdef INT64_AS_LONG_LONG
case 2: RETSIZE(_int64); break; /* MSVC doesn't allow long long */
# else /* INT64_AS_LONG_LONG undefined */
case 2: RETSIZE(long long int); break;
# endif /* INT64_AS_LONG_LONG */
case -1: RETSIZE(short int); break;
}
break;
case 2: /* char */
if (intsize==0) RETSIZE(char);
else scheme_signal_error(MYNAME": cannot qualify 'char");
break;
case 3: /* void */
if (intsize==0 && stars>0) RETSIZE(void);
else if (stars==0)
scheme_signal_error(MYNAME": cannot use 'void without a '*");
else scheme_signal_error(MYNAME": cannot qualify 'void");
break;
case 4: /* float */
if (intsize==0) RETSIZE(float);
else scheme_signal_error(MYNAME": bad qualifiers for 'float");
break;
case 5: /* double */
if (intsize==0) RETSIZE(double);
else if (intsize==1) RETSIZE(long double);
else scheme_signal_error(MYNAME": bad qualifiers for 'double");
break;
default:
scheme_signal_error(MYNAME": internal error (unexpected type %d)",
basetype);
}
# undef RETSIZE
return scheme_make_integer(res);
}
#undef MYNAME
/*****************************************************************************/
/* Pointer type user functions */
static Scheme_Object *nonatomic_sym;
static Scheme_Object *atomic_sym;
static Scheme_Object *stubborn_sym;
static Scheme_Object *uncollectable_sym;
static Scheme_Object *eternal_sym;
static Scheme_Object *interior_sym;
static Scheme_Object *atomic_interior_sym;
static Scheme_Object *raw_sym;
static Scheme_Object *fail_ok_sym;
/* (malloc num type cpointer mode) -> pointer */
/* The arguments for this function are:
* - num: bytes to allocate, or the number of instances of type when given,
* - type: malloc the size of this type (or num instances of it),
* - cpointer: a source pointer to copy contents from,
* - mode: a symbol for different allocation functions to use - one of
* 'nonatomic, 'atomic, 'stubborn, 'uncollectable, 'eternal, 'raw (the last
* one is for using the real malloc)
* - if an additional 'fail-ok flag is given, then scheme_malloc_fail_ok is
* used with the chosen malloc function
* The arguments can be specified in any order at all since they are all
* different types, the only requirement is for a size, either a number of
* bytes or a type. If no mode is specified, then scheme_malloc will be used
* when the type is any pointer, otherwise scheme_malloc_atomic is used. */
#define MYNAME "malloc"
static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
{
int i, size=0, num=0, failok=0;
void *from = NULL, *res = NULL;
long foff = 0;
Scheme_Object *mode = NULL, *a, *base = NULL;
void *(*mf)(size_t);
for (i=0; i<argc; i++) {
a = argv[i];
if (SCHEME_INTP(a)) {
if (num != 0)
scheme_signal_error(MYNAME": specifying a second integer size: %V", a);
num = SCHEME_INT_VAL(a);
if (num <= 0)
scheme_wrong_type(MYNAME, "positive-integer", 0, argc, argv);
} else if (SCHEME_CTYPEP(a)) {
if (size != 0)
scheme_signal_error(MYNAME": specifying a second type: %V", a);
if (NULL == (base = get_ctype_base(a)))
scheme_wrong_type(MYNAME, "C-type", i, argc, argv);
size = ctype_sizeof(a);
if (size <= 0)
scheme_wrong_type(MYNAME, "non-void-C-type", i, argc, argv);
} else if (SAME_OBJ(a, fail_ok_sym)) {
failok = 1;
} else if (SCHEME_SYMBOLP(a)) {
if (mode != NULL)
scheme_signal_error(MYNAME": specifying a second mode symbol: %V", a);
mode = a;
} else if (SCHEME_FFIANYPTRP(a) && !SCHEME_FALSEP(a)) {
if (from != NULL)
scheme_signal_error(MYNAME": specifying a second source pointer: %V",
a);
from = SCHEME_FFIANYPTR_VAL(a);
foff = SCHEME_FFIANYPTR_OFFSET(a);
} else {
scheme_wrong_type(MYNAME, "malloc-argument", i, argc, argv);
}
}
if ((num == 0) && (size == 0)) scheme_signal_error(MYNAME": no size given");
size = ((size==0) ? 1 : size) * ((num==0) ? 1 : num);
if (mode == NULL)
mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_gcpointer)
? scheme_malloc : scheme_malloc_atomic;
else if (SAME_OBJ(mode, nonatomic_sym)) mf = scheme_malloc;
else if (SAME_OBJ(mode, atomic_sym)) mf = scheme_malloc_atomic;
else if (SAME_OBJ(mode, stubborn_sym)) mf = scheme_malloc_stubborn;
else if (SAME_OBJ(mode, eternal_sym)) mf = scheme_malloc_eternal;
else if (SAME_OBJ(mode, uncollectable_sym)) mf = scheme_malloc_uncollectable;
else if (SAME_OBJ(mode, interior_sym)) mf = scheme_malloc_atomic_allow_interior;
else if (SAME_OBJ(mode, atomic_interior_sym)) mf = scheme_malloc_atomic_allow_interior;
else if (SAME_OBJ(mode, raw_sym)) mf = malloc;
else {
scheme_signal_error(MYNAME": bad allocation mode: %V", mode);
return NULL; /* hush the compiler */
}
if (failok) res = scheme_malloc_fail_ok(mf,size); else res = mf(size);
if (((from != NULL) || (foff != 0)) && (res != NULL))
memcpy(res, W_OFFSET(from, foff), size);
if (SAME_OBJ(mode, raw_sym))
return scheme_make_foreign_external_cpointer(res);
else
return scheme_make_foreign_cpointer(res);
}
#undef MYNAME
/* (end-stubborn-change ptr) */
#define MYNAME "end-stubborn-change"
static Scheme_Object *foreign_end_stubborn_change(int argc, Scheme_Object *argv[])
{
void *ptr;
long poff;
if (!SCHEME_FFIANYPTRP(argv[0]))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_end_stubborn_change(W_OFFSET(ptr, poff));
return scheme_void;
}
#undef MYNAME
/* (free ptr) */
/* This is useful for raw-malloced objects, including objects from C libraries
* that the library is mallocing itself. */
#define MYNAME "free"
static Scheme_Object *foreign_free(int argc, Scheme_Object *argv[])
{
void *ptr;
long poff;
if (!SCHEME_FFIANYPTRP(argv[0]))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
free(W_OFFSET(ptr, poff));
return scheme_void;
}
#undef MYNAME
/* (malloc-immobile-cell v) */
#define MYNAME "malloc-immobile-cell"
static Scheme_Object *foreign_malloc_immobile_cell(int argc, Scheme_Object *argv[])
{
return scheme_make_foreign_external_cpointer(scheme_malloc_immobile_box(argv[0]));
}
#undef MYNAME
/* (free-immobile-cell b) */
#define MYNAME "free-immobile-cell"
static Scheme_Object *foreign_free_immobile_cell(int argc, Scheme_Object *argv[])
{
void *ptr;
long poff;
if (!SCHEME_FFIANYPTRP(argv[0]))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_free_immobile_box((void **)W_OFFSET(ptr, poff));
return scheme_void;
}
#undef MYNAME
#define C_LONG_TYPE_STR "exact integer that fits a C long"
/* (ptr-add cptr offset-k [type])
* Adds an offset to a pointer, returning an offset_cpointer value
* (ptr-add! cptr offset-k [type])
* Modifies an existing offset_cpointer value by adjusting its offset field,
* returns void
*/
static Scheme_Object *do_ptr_add(const char *who, int is_bang,
int argc, Scheme_Object **argv)
{
long noff;
if (is_bang) {
if (!SCHEME_CPOINTER_W_OFFSET_P(argv[0]))
scheme_wrong_type(who, "offset-cpointer", 0, argc, argv);
} else {
if (!SCHEME_FFIANYPTRP(argv[0]))
scheme_wrong_type(who, "cpointer", 0, argc, argv);
}
if (!scheme_get_int_val(argv[1], &noff))
scheme_wrong_type(who, C_LONG_TYPE_STR, 1, argc, argv);
if (argc > 2) {
if (SCHEME_CTYPEP(argv[2])) {
long size;
size = ctype_sizeof(argv[2]);
if (size <= 0) scheme_wrong_type(who, "non-void-C-type", 2, argc, argv);
noff = noff * size;
} else
scheme_wrong_type(who, "C-type", 2, argc, argv);
}
if (is_bang) {
((Scheme_Offset_Cptr*)(argv[0]))->offset += noff;
return scheme_void;
} else {
if (SCHEME_CPTRP(argv[0]) && (SCHEME_CPTR_FLAGS(argv[0]) & 0x1))
return scheme_make_offset_external_cptr
(SCHEME_FFIANYPTR_VAL(argv[0]),
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
else
return scheme_make_offset_cptr
(SCHEME_FFIANYPTR_VAL(argv[0]),
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
}
}
/* (ptr-add cptr offset-k [type]) */
#define MYNAME "ptr-add"
static Scheme_Object *foreign_ptr_add(int argc, Scheme_Object *argv[])
{
return do_ptr_add(MYNAME, 0, argc, argv);
}
#undef MYNAME
/* (ptr-add! cptr offset-k [type]) */
#define MYNAME "ptr-add!"
static Scheme_Object *foreign_ptr_add_bang(int argc, Scheme_Object *argv[])
{
return do_ptr_add(MYNAME, 1, argc, argv);
}
#undef MYNAME
/* (offset-ptr? x) */
/* Returns #t if the argument is a cpointer with an offset */
#define MYNAME "offset-ptr?"
static Scheme_Object *foreign_offset_ptr_p(int argc, Scheme_Object *argv[])
{
return (SCHEME_CPOINTER_W_OFFSET_P(argv[0])) ? scheme_true : scheme_false;
}
#undef MYNAME
/* (ptr-offset ptr) */
/* Returns the offset of a cpointer (0 if it's not an offset pointer) */
#define MYNAME "ptr-offset"
static Scheme_Object *foreign_ptr_offset(int argc, Scheme_Object *argv[])
{
if (!SCHEME_FFIANYPTRP(argv[0]))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
return scheme_make_integer_value(SCHEME_FFIANYPTR_OFFSET(argv[0]));
}
#undef MYNAME
/* (set-ptr-offset! ptr offset [type]) */
/* Sets the offset of an offset-cpointer (possibly multiplied by the size of
* the given ctype) */
#define MYNAME "set-ptr-offset!"
static Scheme_Object *foreign_set_ptr_offset_bang(int argc, Scheme_Object *argv[])
{
long noff;
if (!SCHEME_CPOINTER_W_OFFSET_P(argv[0]))
scheme_wrong_type(MYNAME, "offset-cpointer", 0, argc, argv);
if (!scheme_get_int_val(argv[1], &noff)) {
scheme_wrong_type(MYNAME, C_LONG_TYPE_STR, 1, argc, argv);
}
if (argc > 2) {
if (SCHEME_CTYPEP(argv[2])) {
long size;
if (NULL == get_ctype_base(argv[2]))
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
size = ctype_sizeof(argv[2]);
if (size <= 0)
scheme_wrong_type(MYNAME, "non-void-C-type", 2, argc, argv);
noff = noff * size;
} else
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
}
((Scheme_Offset_Cptr*)(argv[0]))->offset = noff;
return scheme_void;
}
#undef MYNAME
/* (mem{move,cpy} dest-ptr [dest-offset] src-ptr [src-offset] count [ctype])
* Copies count * sizeof(ctype) bytes
* from src-ptr + src-offset * sizeof(ctype)
* to dest-ptr + dest-offset * sizeof(ctype).
* --or--
* (memset dest-ptr [dest-offset] byte count [ctype])
* Sets count * sizeof(ctype) bytes to byte
* at dest-ptr + dest-offset * sizeof(ctype) */
static Scheme_Object *do_memop(const char *who, int mode,
int argc, Scheme_Object **argv)
/* mode 0=>memset, 1=>memmove, 2=>memcpy */
{
void *src = NULL, *dest = NULL;
long soff = 0, doff = 0, count, v, mult = 0;
int i, j, ch = 0, argc1 = argc;
/* arg parsing: last optional ctype, then count, then fill byte for memset,
* then the first and second pointer+offset pair. */
/* get the optional last ctype multiplier */
if (SCHEME_CTYPEP(argv[argc1-1])) {
argc1--;
mult = ctype_sizeof(argv[argc1]);
if (mult <= 0)
scheme_wrong_type(who, "non-void-C-type", argc1, argc, argv);
}
/* get the count argument */
argc1--;
if ((!scheme_get_int_val(argv[argc1], &count)) || (count < 0))
scheme_wrong_type(who, "count as " C_LONG_TYPE_STR, argc1, argc, argv);
if (mult) count *= mult;
/* get the fill byte for memset */
if (!mode) {
argc1--;
ch = SCHEME_INTP(argv[argc1]) ? SCHEME_INT_VAL(argv[argc1]) : -1;
if ((ch < 0) || (ch > 255))
scheme_wrong_type(who, "byte", argc1, argc, argv);
}
/* get the two pointers + offsets */
i = 0;
for (j=0; j<2; j++) {
if (!mode && j==1) break; /* memset needs only a dest argument */
if (!(i<argc1))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: missing a pointer argument for %s",
who, (j == 0 ? "destination" : "source"));
if (!SCHEME_FFIANYPTRP(argv[i]))
scheme_wrong_type(who, "cpointer", i, argc, argv);
switch (j) {
case 0: dest = SCHEME_FFIANYPTR_VAL(argv[i]);
doff = SCHEME_FFIANYPTR_OFFSET(argv[i]);
break;
case 1: src = SCHEME_FFIANYPTR_VAL(argv[i]);
soff = SCHEME_FFIANYPTR_OFFSET(argv[i]);
break;
}
i++;
if ((i<argc1) && SCHEME_EXACT_INTEGERP(argv[i])) {
if (!scheme_get_int_val(argv[i], &v))
scheme_wrong_type(who, C_LONG_TYPE_STR, i, argc, argv);
if (mult) v *= mult;
switch (j) {
case 0: doff += v; break;
case 1: soff += v; break;
}
i++;
}
}
/* verify that there are no unused leftovers */
if (!(i==argc1))
scheme_arg_mismatch(who, "unexpected extra argument: ", argv[i]);
switch (mode) {
case 0: memset (W_OFFSET(dest, doff), ch, count); break;
case 1: memmove(W_OFFSET(dest, doff), W_OFFSET(src, soff), count); break;
case 2: memcpy (W_OFFSET(dest, doff), W_OFFSET(src, soff), count); break;
}
return scheme_void;
}
#define MYNAME "memset"
static Scheme_Object *foreign_memset(int argc, Scheme_Object *argv[])
{
return do_memop(MYNAME, 0, argc, argv);
}
#undef MYNAME
#define MYNAME "memmove"
static Scheme_Object *foreign_memmove(int argc, Scheme_Object *argv[])
{
return do_memop(MYNAME, 1, argc, argv);
}
#undef MYNAME
#define MYNAME "memcpy"
static Scheme_Object *foreign_memcpy(int argc, Scheme_Object *argv[])
{
return do_memop(MYNAME, 2, argc, argv);
}
#undef MYNAME
static Scheme_Object *abs_sym;
/* (ptr-ref cpointer type [['abs] n]) -> the object at the given location */
/* n defaults to 0 which is the only value that should be used with ffi_objs */
/* if n is given, an 'abs flag can precede it to make n be a byte offset */
/* rather than some multiple of sizeof(type). */
/* WARNING: there are *NO* checks at all, this is raw C level code. */
#define MYNAME "ptr-ref"
static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
{
int size=0; void *ptr; Scheme_Object *base;
long delta;
if (!SCHEME_FFIANYPTRP(argv[0]))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
if ((ptr == NULL) && (delta == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
if (NULL == (base = get_ctype_base(argv[1])))
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
size = ctype_sizeof(base);
if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
if (SCHEME_FFIOBJP(argv[0])) {
/* The ffiobj pointer is the function pointer. */
ptr = argv[0];
delta = (long)&(((ffi_obj_struct*)0x0)->obj);
}
}
if (size < 0) {
/* should not happen */
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
} else if (size == 0) {
scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
}
if (argc > 3) {
if (!SAME_OBJ(argv[2],abs_sym))
scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
if (!SCHEME_INTP(argv[3]))
scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
delta += SCHEME_INT_VAL(argv[3]);
} else if (argc > 2) {
if (!SCHEME_INTP(argv[2]))
scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
if (!size)
scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
delta += (size * SCHEME_INT_VAL(argv[2]));
}
return C2SCHEME(argv[1], ptr, delta, 0);
}
#undef MYNAME
/* (ptr-set! cpointer type [['abs] n] value) -> void */
/* n defaults to 0 which is the only value that should be used with ffi_objs */
/* if n is given, an 'abs flag can precede it to make n be a byte offset */
/* rather than some multiple of sizeof(type). */
/* WARNING: there are *NO* checks at all, this is raw C level code. */
#define MYNAME "ptr-set!"
static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[])
{
int size=0; void *ptr;
long delta;
Scheme_Object *val = argv[argc-1], *base;
if (!SCHEME_FFIANYPTRP(argv[0]))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
if ((ptr == NULL) && (delta == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
if (NULL == (base = get_ctype_base(argv[1])))
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
size = ctype_sizeof(base);
if (size < 0) {
/* should not happen */
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
} else if (size == 0) {
scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
}
if (argc > 4) {
if (!SAME_OBJ(argv[2],abs_sym))
scheme_wrong_type(MYNAME, "'abs", 2, argc, argv);
if (!SCHEME_INTP(argv[3]))
scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
delta += SCHEME_INT_VAL(argv[3]);
} else if (argc > 3) {
if (!SCHEME_INTP(argv[2]))
scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
if (!size)
scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
delta += (size * SCHEME_INT_VAL(argv[2]));
}
SCHEME2C(argv[1], ptr, delta, val, NULL, NULL, 0);
return scheme_void;
}
#undef MYNAME
/* (ptr-equal? cpointer cpointer) -> boolean */
#define MYNAME "ptr-equal?"
static Scheme_Object *foreign_ptr_equal_p(int argc, Scheme_Object *argv[])
{
if (!SCHEME_FFIANYPTRP(argv[0]))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
if (!SCHEME_FFIANYPTRP(argv[1]))
scheme_wrong_type(MYNAME, "cpointer", 1, argc, argv);
return (SAME_OBJ(argv[0],argv[1]) ||
(SCHEME_FFIANYPTR_OFFSETVAL(argv[0])
== SCHEME_FFIANYPTR_OFFSETVAL(argv[1])))
? scheme_true : scheme_false;
}
#undef MYNAME
/* (make-sized-byte-string cpointer len) */
#define MYNAME "make-sized-byte-string"
static Scheme_Object *foreign_make_sized_byte_string(int argc, Scheme_Object *argv[])
{
/* Warning: no copying is done so it is possible to share string contents. */
/* Warning: if source ptr has a offset, resulting string object uses shifted
* pointer.
* (Should use real byte-strings with new version.) */
long len;
if (!SCHEME_FFIANYPTRP(argv[0]))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
if (!scheme_get_int_val(argv[1],&len))
scheme_wrong_type(MYNAME, "integer in a C long range", 1, argc, argv);
if (SCHEME_FALSEP(argv[0])) return scheme_false;
else return
scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(argv[0]),
len, 0);
}
#undef MYNAME
/* *** Calling Scheme code while the GC is working leads to subtle bugs, so
*** this is implemented now in Scheme using will executors. */
/* internal: apply Scheme finalizer */
void do_scm_finalizer(void *p, void *finalizer)
{
Scheme_Object *f = (Scheme_Object*)finalizer;
if (!SCHEME_FALSEP(f)) _scheme_apply(f, 1, (Scheme_Object**)(void*)(&p));
}
void do_ptr_finalizer(void *p, void *finalizer)
{
Scheme_Object *f = (Scheme_Object*)finalizer;
Scheme_Object *ptr;
if (p == NULL) return;
ptr = scheme_make_cptr(p,NULL);
if (!SCHEME_FALSEP(f)) _scheme_apply(f, 1, (Scheme_Object**)(&ptr));
/* don't leave dangling references! */
SCHEME_CPTR_VAL(ptr) = NULL;
ptr = NULL;
}
/* (register-finalizer ptrobj finalizer ['pointer]) -> old-finalizer */
/* The finalizer is called by the primitive finalizer mechanism, make sure */
/* no references to the object are recreated. #f means erase existing */
/* finalizer if any.*/
/* If no 'pointer argument is given, this is can be used with any Scheme */
/* object, and the finalizer will be called with it. If an additional */
/* 'pointer argument of 'pointer is given, the object must be a cpointer */
/* object, the finalizer will be invoked when the pointer itself is */
/* unreachable, and it will get a new cpointer object that points to it. */
/* (Only needed in cases where pointer aliases might be created.) */
/*
* defsymbols[pointer]
* cdefine[register-finalizer 2 3]{
* void *ptr, *old = NULL;
* int ptrsym = (argc == 3 && argv[2] == pointer_sym);
* if (ptrsym) {
* if (!SCHEME_FFIANYPTRP(argv[0]))
* scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
* ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
* if (ptr == NULL)
* scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
* } else {
* if (argc == 3)
* scheme_wrong_type(MYNAME, "pointer-mode", 2, argc, argv);
* ptr = argv[0];
* }
* if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1])))
* scheme_wrong_type(MYNAME, "procedure-or-false", 1, argc, argv);
* scheme_register_finalizer
* (ptr, (ptrsym ? do_ptr_finalizer : do_scm_finalizer),
* argv[1], NULL, &old);
* return (old == NULL) ? scheme_false : (Scheme_Object*)old;
* }
*/
/*****************************************************************************/
/* Calling foreign function objects */
#define MAX_QUICK_ARGS 16
typedef void(*VoidFun)();
Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
/* data := {name, c-function, itypes, otype, cif} */
{
/* The name is not currently used */
/* char *name = SCHEME_BYTE_STR_VAL(SCHEME_VEC_ELS(data)[0]); */
void *c_func = (void*)(SCHEME_VEC_ELS(data)[1]);
Scheme_Object *itypes = SCHEME_VEC_ELS(data)[2];
Scheme_Object *otype = SCHEME_VEC_ELS(data)[3];
Scheme_Object *base;
ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]);
long cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]);
int nargs = cif->nargs;
/* When the foreign function is called, we need an array (ivals) of nargs
* ForeignAny objects to store the actual C values that are created, and we
* need another array (avalues) for the pointers to these values (this is
* what libffi actually uses). To make things more fun, ForeignAny is
* problematic for the precise GC, since it is sometimes a pointer and
* sometime not. To deal with this, while converting argv objects into
* ivals, scheme_to_c will save pointer values in avalues, so the GC can,
* ignore ivals -- just before we reach the actual call, avalues is
* overwritten, but from that point on it is all C code so there is no
* problem. Hopefully.
* (Things get complicated if the C call can involve GC (usually due to a
* Scheme callback), but then the programmer need to arrange for pointers
* that cannot move. Because of all this, the *only* array that should not
* be ignored by the GC is avalues.)
*/
GC_CAN_IGNORE ForeignAny *ivals, oval;
void **avalues, *p, *newp, *tmp;
GC_CAN_IGNORE ForeignAny stack_ivals[MAX_QUICK_ARGS];
void *stack_avalues[MAX_QUICK_ARGS];
long stack_offsets[MAX_QUICK_ARGS];
int i;
long basetype, offset, *offsets;
if (nargs <= MAX_QUICK_ARGS) {
ivals = stack_ivals;
avalues = stack_avalues;
offsets = stack_offsets;
} else {
ivals = malloc(nargs * sizeof(ForeignAny));
avalues = scheme_malloc(nargs * sizeof(void*));
offsets = scheme_malloc(nargs * sizeof(long));
}
/* iterate on input values and types */
for (i=0; i<nargs; i++, itypes=SCHEME_CDR(itypes)) {
/* convert argv[i] according to current itype */
offset = 0;
p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype,
&offset, 0);
if ((p != NULL) || offset) {
avalues[i] = p;
ivals[i].x_fixnum = basetype; /* remember the base type */
} else {
avalues[i] = NULL;
}
offsets[i] = offset;
}
base = get_ctype_base(otype); /* verified below, so cannot be NULL */
/* If this is a struct return value, then need to malloc in any case, even if
* the size is smaller than ForeignAny, because this value will be
* returned. */
if (CTYPE_PRIMLABEL(base) == FOREIGN_struct) {
/* need to have p be a pointer that is invisible to the GC */
p = malloc(CTYPE_PRIMTYPE(base)->size);
newp = scheme_malloc_atomic(CTYPE_PRIMTYPE(base)->size);
} else {
p = &oval;
newp = NULL;
}
/* We finished with all possible mallocs, clear up the avalues and offsets
* mess */
for (i=0; i<nargs; i++) {
if ((avalues[i] == NULL) && !offsets[i]) /* if this was a non-pointer... */
avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
else if (ivals[i].x_fixnum != FOREIGN_struct) { /* if *not* a struct... */
/* ... set the ivals pointer (pointer type doesn't matter) and avalues */
ivals[i].x_pointer = avalues[i];
avalues[i] = &(ivals[i]);
}
/* Otherwise it was a struct pointer, and avalues[i] is already fine. */
/* Add offset, if any: */
if (offsets[i] != 0) {
ivals[i].x_pointer = (char *)ivals[i].x_pointer + offsets[i];
}
}
/* Finally, call the function */
ffi_call(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues);
if (ivals != stack_ivals) free(ivals);
ivals = NULL; /* no need now to hold on to this */
for (i=0; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */
avalues = NULL;
switch (CTYPE_PRIMLABEL(base)) {
case FOREIGN_struct:
memcpy(newp, p, CTYPE_PRIMTYPE(base)->size);
free(p);
p = newp;
break;
default:
/* not sure why this code is here, looks fine to remove this case */
if (CTYPE_PRIMTYPE(base) == &ffi_type_pointer) {
tmp = ((void**)p)[0];
p = &tmp;
}
break;
}
return C2SCHEME(otype, p, 0, 1);
}
/* see below */
void free_fficall_data(void *ignored, void *p)
{
free(((ffi_cif*)p)->arg_types);
free(p);
}
/* (ffi-call ffi-obj in-types out-type [abi]) -> (in-types -> out-value) */
/* the real work is done by ffi_do_call above */
#define MYNAME "ffi-call"
static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
{
static Scheme_Object *ffi_name_prefix = NULL;
Scheme_Object *itypes = argv[1];
Scheme_Object *otype = argv[2];
Scheme_Object *obj, *data, *p, *base;
ffi_abi abi;
long ooff;
GC_CAN_IGNORE ffi_type *rtype, **atypes;
GC_CAN_IGNORE ffi_cif *cif;
int i, nargs;
MZ_REGISTER_STATIC(ffi_name_prefix);
if (!ffi_name_prefix)
ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:");
if (!SCHEME_FFIANYPTRP(argv[0]))
scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv);
obj = SCHEME_FFIANYPTR_VAL(argv[0]);
ooff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
if ((obj == NULL) && (ooff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
nargs = scheme_proper_list_length(itypes);
if (nargs < 0)
scheme_wrong_type(MYNAME, "proper list", 1, argc, argv);
if (NULL == (base = get_ctype_base(otype)))
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
rtype = CTYPE_PRIMTYPE(base);
abi = GET_ABI(MYNAME,3);
atypes = malloc(nargs * sizeof(ffi_type*));
for (i=0, p=itypes; i<nargs; i++, p=SCHEME_CDR(p)) {
if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
scheme_wrong_type(MYNAME, "list-of-C-types", 1, argc, argv);
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv);
atypes[i] = CTYPE_PRIMTYPE(base);
}
cif = malloc(sizeof(ffi_cif));
if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
data = scheme_make_vector(6, NULL);
p = scheme_append_byte_string
(ffi_name_prefix,
scheme_make_byte_string_without_copying
(SCHEME_FFIOBJP(argv[0]) ?
((ffi_obj_struct*)(argv[0]))->name : "proc"));
SCHEME_VEC_ELS(data)[0] = p;
SCHEME_VEC_ELS(data)[1] = obj;
SCHEME_VEC_ELS(data)[2] = itypes;
SCHEME_VEC_ELS(data)[3] = otype;
SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif;
SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff);
scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL);
return scheme_make_closed_prim_w_arity
(ffi_do_call, (void*)data, SCHEME_BYTE_STR_VAL(p),
nargs, nargs);
}
#undef MYNAME
/*****************************************************************************/
/* Scheme callbacks */
void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
{
ffi_callback_struct *data;
Scheme_Object *argv_stack[MAX_QUICK_ARGS];
int argc = cif->nargs, i;
Scheme_Object **argv, *p, *v;
#ifdef MZ_PRECISE_GC
{
void *tmp;
tmp = *((void**)userdata);
data = (ffi_callback_struct*)(SCHEME_WEAK_BOX_VAL(tmp));
if (data == NULL) scheme_signal_error("callback lost");
}
#else
data = (ffi_callback_struct*)userdata;
#endif
if (argc <= MAX_QUICK_ARGS)
argv = argv_stack;
else
argv = scheme_malloc(argc * sizeof(Scheme_Object*));
if (data->call_in_scheduler)
scheme_start_in_scheduler();
for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0);
argv[i] = v;
}
p = _scheme_apply(data->proc, argc, argv);
SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1);
if (data->call_in_scheduler)
scheme_end_in_scheduler();
}
/* see ffi-callback below */
typedef struct closure_and_cif_struct {
ffi_closure closure;
ffi_cif cif;
#ifdef MZ_PRECISE_GC
struct immobile_box *data;
#else
void *data;
#endif
} closure_and_cif;
/* free the above */
void free_cl_cif_args(void *ignored, void *p)
{
/*
scheme_warning("Releasing cl+cif+args %V %V (%d)",
ignored,
(((closure_and_cif*)p)->data),
SAME_OBJ(ignored,(((closure_and_cif*)p)->data)));
*/
#ifdef MZ_PRECISE_GC
GC_free_immobile_box((void**)(((closure_and_cif*)p)->data));
#endif
scheme_free_code(p);
}
/* (ffi-callback scheme-proc in-types out-type [abi]) -> ffi-callback */
/* the treatment of in-types and out-types is similar to that in ffi-call */
/* the real work is done by ffi_do_callback above */
#define MYNAME "ffi-callback"
static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[])
{
ffi_callback_struct *data;
Scheme_Object *itypes = argv[1];
Scheme_Object *otype = argv[2];
Scheme_Object *p, *base;
ffi_abi abi;
int nargs, i;
/* ffi_closure objects are problematic when used with a moving GC. The
* problem is that memory that is GC-visible can move at any time. The
* solution is to use an immobile-box, which an immobile pointer (in a simple
* malloced block), which points to the ffi_callback_struct that contains the
* relevant Scheme call details. Another minor complexity is that an
* immobile box serves as a reference for the GC, which means that nothing
* will ever get collected: and the solution for this is to stick a weak-box
* in the chain. Users need to be aware of GC issues, and need to keep a
* reference to the callback object to avoid releasing the whole thing --
* when that reference is lost, the ffi_callback_struct will be GCed, and a
* finalizer will free() the malloced memory. Everything on the malloced
* part is allocated in one block, to make it easy to free. The final layout
* of the various objects is:
*
* <<======malloc======>> : <<===========scheme_malloc===============>>
* :
* ffi_closure <------------------------\
* | | : |
* | | : |
* | \--> immobile ----> weak |
* | box : box |
* | : | |
* | : | |
* | : \--> ffi_callback_struct
* | : | |
* V : | \-----> Scheme Closure
* cif ---> atypes : |
* : \--------> input/output types
*/
GC_CAN_IGNORE ffi_type *rtype, **atypes;
GC_CAN_IGNORE ffi_cif *cif;
GC_CAN_IGNORE ffi_closure *cl;
GC_CAN_IGNORE closure_and_cif *cl_cif_args;
if (!SCHEME_PROCP(argv[0]))
scheme_wrong_type(MYNAME, "procedure", 0, argc, argv);
nargs = scheme_proper_list_length(itypes);
if (nargs < 0)
scheme_wrong_type(MYNAME, "proper list", 1, argc, argv);
if (NULL == (base = get_ctype_base(otype)))
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
rtype = CTYPE_PRIMTYPE(base);
abi = GET_ABI(MYNAME,3);
/* malloc space for everything needed, so a single free gets rid of this */
cl_cif_args = scheme_malloc_code(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*));
cl = &(cl_cif_args->closure); /* cl is the same as cl_cif_args */
cif = &(cl_cif_args->cif);
atypes = (ffi_type **)(((char*)cl_cif_args) + sizeof(closure_and_cif));
for (i=0, p=itypes; i<nargs; i++, p=SCHEME_CDR(p)) {
if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
scheme_wrong_type(MYNAME, "list-of-C-types", 1, argc, argv);
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv);
atypes[i] = CTYPE_PRIMTYPE(base);
}
if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
data = (ffi_callback_struct*)scheme_malloc_tagged(sizeof(ffi_callback_struct));
data->so.type = ffi_callback_tag;
data->callback = (cl_cif_args);
data->proc = (argv[0]);
data->itypes = (argv[1]);
data->otype = (argv[2]);
data->call_in_scheduler = (((argc > 4) && SCHEME_TRUEP(argv[4])));
# ifdef MZ_PRECISE_GC
{
/* put data in immobile, weak box */
void **tmp;
tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0));
cl_cif_args->data = (struct immobile_box*)tmp;
}
# else /* MZ_PRECISE_GC undefined */
cl_cif_args->data = (void*)data;
# endif /* MZ_PRECISE_GC */
if (ffi_prep_closure(cl, cif, &ffi_do_callback, (void*)(cl_cif_args->data))
!= FFI_OK)
scheme_signal_error
("internal error: ffi_prep_closure did not return FFI_OK");
scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL);
return (Scheme_Object*)data;
}
#undef MYNAME
/*****************************************************************************/
void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
{
char *str;
if (!SCHEME_CTYPEP(ctype))
scheme_wrong_type("Scheme->C", "C-type", 0, 1, &ctype);
if (CTYPE_PRIMP(ctype)) {
scheme_print_bytes(pp, "#<ctype:", 0, 8);
ctype = CTYPE_BASETYPE(ctype);
if (SCHEME_SYMBOLP(ctype)) {
str = SCHEME_SYM_VAL(ctype);
scheme_print_bytes(pp, str, 0, strlen(str));
} else {
scheme_print_bytes(pp, "cstruct", 0, 7);
}
scheme_print_bytes(pp, ">", 0, 1);
} else {
scheme_print_bytes(pp, "#<ctype>", 0, 8);
}
}
/*****************************************************************************/
/* Initialization */
/* types need to be initialized before places can spawn
* types become entries in the GC mark and fixup tables
* this function should initialize read-only globals that can be
* shared without locking */
void scheme_init_foreign_globals()
{
ffi_lib_tag = scheme_make_type("<ffi-lib>");
ffi_obj_tag = scheme_make_type("<ffi-obj>");
ctype_tag = scheme_make_type("<ctype>");
ffi_callback_tag = scheme_make_type("<ffi-callback>");
# ifdef MZ_PRECISE_GC
GC_register_traversers(ffi_lib_tag, ffi_lib_SIZE, ffi_lib_MARK, ffi_lib_FIXUP, 1, 0);
GC_register_traversers(ffi_obj_tag, ffi_obj_SIZE, ffi_obj_MARK, ffi_obj_FIXUP, 1, 0);
GC_register_traversers(ctype_tag, ctype_SIZE, ctype_MARK, ctype_FIXUP, 1, 0);
GC_register_traversers(ffi_callback_tag, ffi_callback_SIZE, ffi_callback_MARK, ffi_callback_FIXUP, 1, 0);
# endif /* MZ_PRECISE_GC */
scheme_set_type_printer(ctype_tag, ctype_printer);
MZ_REGISTER_STATIC(opened_libs);
opened_libs = scheme_make_hash_table(SCHEME_hash_string);
MZ_REGISTER_STATIC(default_sym);
default_sym = scheme_intern_symbol("default");
MZ_REGISTER_STATIC(stdcall_sym);
stdcall_sym = scheme_intern_symbol("stdcall");
MZ_REGISTER_STATIC(sysv_sym);
sysv_sym = scheme_intern_symbol("sysv");
MZ_REGISTER_STATIC(nonatomic_sym);
nonatomic_sym = scheme_intern_symbol("nonatomic");
MZ_REGISTER_STATIC(atomic_sym);
atomic_sym = scheme_intern_symbol("atomic");
MZ_REGISTER_STATIC(stubborn_sym);
stubborn_sym = scheme_intern_symbol("stubborn");
MZ_REGISTER_STATIC(uncollectable_sym);
uncollectable_sym = scheme_intern_symbol("uncollectable");
MZ_REGISTER_STATIC(eternal_sym);
eternal_sym = scheme_intern_symbol("eternal");
MZ_REGISTER_STATIC(interior_sym);
interior_sym = scheme_intern_symbol("interior");
MZ_REGISTER_STATIC(atomic_interior_sym);
atomic_interior_sym = scheme_intern_symbol("atomic-interior");
MZ_REGISTER_STATIC(raw_sym);
raw_sym = scheme_intern_symbol("raw");
MZ_REGISTER_STATIC(fail_ok_sym);
fail_ok_sym = scheme_intern_symbol("fail-ok");
MZ_REGISTER_STATIC(abs_sym);
abs_sym = scheme_intern_symbol("abs");
}
void scheme_init_foreign(Scheme_Env *env)
{
Scheme_Env *menv;
ctype_struct *t;
Scheme_Object *s;
memcpy(&ffi_type_gcpointer, &ffi_type_pointer, sizeof(ffi_type_pointer));
menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
scheme_add_global("ffi-lib?",
scheme_make_prim_w_arity(foreign_ffi_lib_p, "ffi-lib?", 1, 1), menv);
scheme_add_global("ffi-lib",
scheme_make_prim_w_arity(foreign_ffi_lib, "ffi-lib", 1, 2), menv);
scheme_add_global("ffi-lib-name",
scheme_make_prim_w_arity(foreign_ffi_lib_name, "ffi-lib-name", 1, 1), menv);
scheme_add_global("ffi-obj?",
scheme_make_prim_w_arity(foreign_ffi_obj_p, "ffi-obj?", 1, 1), menv);
scheme_add_global("ffi-obj",
scheme_make_prim_w_arity(foreign_ffi_obj, "ffi-obj", 2, 2), menv);
scheme_add_global("ffi-obj-lib",
scheme_make_prim_w_arity(foreign_ffi_obj_lib, "ffi-obj-lib", 1, 1), menv);
scheme_add_global("ffi-obj-name",
scheme_make_prim_w_arity(foreign_ffi_obj_name, "ffi-obj-name", 1, 1), menv);
scheme_add_global("ctype?",
scheme_make_prim_w_arity(foreign_ctype_p, "ctype?", 1, 1), menv);
scheme_add_global("ctype-basetype",
scheme_make_prim_w_arity(foreign_ctype_basetype, "ctype-basetype", 1, 1), menv);
scheme_add_global("ctype-scheme->c",
scheme_make_prim_w_arity(foreign_ctype_scheme_to_c, "ctype-scheme->c", 1, 1), menv);
scheme_add_global("ctype-c->scheme",
scheme_make_prim_w_arity(foreign_ctype_c_to_scheme, "ctype-c->scheme", 1, 1), menv);
scheme_add_global("make-ctype",
scheme_make_prim_w_arity(foreign_make_ctype, "make-ctype", 3, 3), menv);
scheme_add_global("make-cstruct-type",
scheme_make_prim_w_arity(foreign_make_cstruct_type, "make-cstruct-type", 1, 2), menv);
scheme_add_global("ffi-callback?",
scheme_make_prim_w_arity(foreign_ffi_callback_p, "ffi-callback?", 1, 1), menv);
scheme_add_global("cpointer?",
scheme_make_prim_w_arity(foreign_cpointer_p, "cpointer?", 1, 1), menv);
scheme_add_global("cpointer-tag",
scheme_make_prim_w_arity(foreign_cpointer_tag, "cpointer-tag", 1, 1), menv);
scheme_add_global("set-cpointer-tag!",
scheme_make_prim_w_arity(foreign_set_cpointer_tag_bang, "set-cpointer-tag!", 2, 2), menv);
scheme_add_global("ctype-sizeof",
scheme_make_prim_w_arity(foreign_ctype_sizeof, "ctype-sizeof", 1, 1), menv);
scheme_add_global("ctype-alignof",
scheme_make_prim_w_arity(foreign_ctype_alignof, "ctype-alignof", 1, 1), menv);
scheme_add_global("compiler-sizeof",
scheme_make_prim_w_arity(foreign_compiler_sizeof, "compiler-sizeof", 1, 1), menv);
scheme_add_global("malloc",
scheme_make_prim_w_arity(foreign_malloc, "malloc", 1, 5), menv);
scheme_add_global("end-stubborn-change",
scheme_make_prim_w_arity(foreign_end_stubborn_change, "end-stubborn-change", 1, 1), menv);
scheme_add_global("free",
scheme_make_prim_w_arity(foreign_free, "free", 1, 1), menv);
scheme_add_global("malloc-immobile-cell",
scheme_make_prim_w_arity(foreign_malloc_immobile_cell, "malloc-immobile-cell", 1, 1), menv);
scheme_add_global("free-immobile-cell",
scheme_make_prim_w_arity(foreign_free_immobile_cell, "free-immobile-cell", 1, 1), menv);
scheme_add_global("ptr-add",
scheme_make_prim_w_arity(foreign_ptr_add, "ptr-add", 2, 3), menv);
scheme_add_global("ptr-add!",
scheme_make_prim_w_arity(foreign_ptr_add_bang, "ptr-add!", 2, 3), menv);
scheme_add_global("offset-ptr?",
scheme_make_prim_w_arity(foreign_offset_ptr_p, "offset-ptr?", 1, 1), menv);
scheme_add_global("ptr-offset",
scheme_make_prim_w_arity(foreign_ptr_offset, "ptr-offset", 1, 1), menv);
scheme_add_global("set-ptr-offset!",
scheme_make_prim_w_arity(foreign_set_ptr_offset_bang, "set-ptr-offset!", 2, 3), menv);
scheme_add_global("memset",
scheme_make_prim_w_arity(foreign_memset, "memset", 3, 5), menv);
scheme_add_global("memmove",
scheme_make_prim_w_arity(foreign_memmove, "memmove", 3, 6), menv);
scheme_add_global("memcpy",
scheme_make_prim_w_arity(foreign_memcpy, "memcpy", 3, 6), menv);
scheme_add_global("ptr-ref",
scheme_make_prim_w_arity(foreign_ptr_ref, "ptr-ref", 2, 4), menv);
scheme_add_global("ptr-set!",
scheme_make_prim_w_arity(foreign_ptr_set_bang, "ptr-set!", 3, 5), menv);
scheme_add_global("ptr-equal?",
scheme_make_prim_w_arity(foreign_ptr_equal_p, "ptr-equal?", 2, 2), menv);
scheme_add_global("make-sized-byte-string",
scheme_make_prim_w_arity(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), menv);
scheme_add_global("ffi-call",
scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv);
scheme_add_global("ffi-callback",
scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 5), menv);
s = scheme_intern_symbol("void");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_void));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_void);
scheme_add_global("_void", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int8");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint8));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int8);
scheme_add_global("_int8", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint8");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint8));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint8);
scheme_add_global("_uint8", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint16));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int16);
scheme_add_global("_int16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint16));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint16);
scheme_add_global("_uint16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int32");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int32);
scheme_add_global("_int32", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint32");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint32);
scheme_add_global("_uint32", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int64");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint64));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int64);
scheme_add_global("_int64", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint64");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint64));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint64);
scheme_add_global("_uint64", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("fixint");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixint);
scheme_add_global("_fixint", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("ufixint");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixint);
scheme_add_global("_ufixint", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("fixnum");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_smzlong));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixnum);
scheme_add_global("_fixnum", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("ufixnum");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_umzlong));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixnum);
scheme_add_global("_ufixnum", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("float");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_float));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_float);
scheme_add_global("_float", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("double");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_double);
scheme_add_global("_double", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("double*");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_doubleS);
scheme_add_global("_double*", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("bool");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_bool);
scheme_add_global("_bool", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("string/ucs-4");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4);
scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("string/utf-16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16);
scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("bytes");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes);
scheme_add_global("_bytes", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("path");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_path);
scheme_add_global("_path", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("symbol");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_symbol);
scheme_add_global("_symbol", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("pointer");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_pointer);
scheme_add_global("_pointer", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("gcpointer");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_gcpointer);
scheme_add_global("_gcpointer", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("scheme");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_scheme);
scheme_add_global("_scheme", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("fpointer");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_fpointer);
scheme_add_global("_fpointer", (Scheme_Object*)t, menv);
scheme_finish_primitive_module(menv);
scheme_protect_primitive_provide(menv, NULL);
}
/*****************************************************************************/
Reference in New Issue View Git Blame Copy Permalink