/******************************************** ** Do not edit this file! ** This file is generated from foreign.rktc, ** to make changes, edit that file and ** run it to generate an updated version ** of this file. ********************************************/ #include "schpriv.h" #ifndef DONT_USE_FOREIGN #include #ifndef WINDOWS_DYNAMIC_LOAD # include # 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 # ifndef __CYGWIN32__ # include 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)) static void save_errno_values(int kind); /* This make hides pointerness from cdefstruct so that it doesn't generate a mark/fixup action: */ #define NON_GCBALE_PTR(t) t* /*****************************************************************************/ /* 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 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; NON_GCBALE_PTR(void) handle; Scheme_Object* name; Scheme_Hash_Table* objects; int is_global; } 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->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->name); gcFIXUP(s->objects); return gcBYTES_TO_WORDS(sizeof(ffi_lib_struct)); } END_XFORM_SKIP; #endif THREAD_LOCAL_DECL(static Scheme_Hash_Table *opened_libs); /* (ffi-lib filename no-error? global?) -> 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, as_global = 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); as_global = ((argc > 2) && SCHEME_TRUEP(argv[2])); /* 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 = LoadLibraryW(WIDE_PATH(name)); # else /* WINDOWS_DYNAMIC_LOAD undefined */ handle = dlopen(name, RTLD_NOW | (as_global ? RTLD_GLOBAL : RTLD_LOCAL)); # 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); lib->is_global = (!name); 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; NON_GCBALE_PTR(void) obj; char* name; NON_GCBALE_PTR(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->name); return gcBYTES_TO_WORDS(sizeof(ffi_obj_struct)); } int ffi_obj_FIXUP(void *p) { ffi_obj_struct *s = (ffi_obj_struct *)p; gcFIXUP(s->name); 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, *lib2; 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 && lib->is_global) { /* Try every handle in the table of opened libraries. */ int i; for (i = opened_libs->size; i--; ) { if (opened_libs->vals[i]) { lib2 = (ffi_lib_struct *)opened_libs->vals[i]; dlobj = dlsym(lib2->handle, dlname); if (dlobj) break; } } } 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 Racket 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 *)((((uintptr_t)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,(intptr_t*)(y)) #define scheme_get_unsigned_realint_val(x,y) \ scheme_get_unsigned_int_val(x,(uintptr_t*)(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 Racket 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. */ MZ_INLINE int scheme_get_realint_val(Scheme_Object *o, int *v) { if (SCHEME_INTP(o)) { uintptr_t lv = SCHEME_INT_VAL(o); int i = (int)lv; if (i != lv) return 0; *v = i; return 1; } else return 0; } MZ_INLINE int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v) { if (SCHEME_INTP(o)) { uintptr_t 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((intptr_t)(ri)) #define scheme_make_realinteger_value_from_unsigned(ri) \ scheme_make_integer((uintptr_t)(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) { intptr_t ulen; unsigned short *res; res = scheme_ucs4_to_utf16 (SCHEME_CHAR_STR_VAL(ucs), 0, SCHEME_CHAR_STRLEN_VAL(ucs), NULL, -1, &ulen, 1); res[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) { intptr_t ulen, end; mzchar *res; if (!utf) return scheme_false; for (end=0; utf[end] != 0; end++) { /**/ } res = scheme_utf16_to_ucs4(utf, 0, end, NULL, -1, &ulen, 1); res[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: * Racket expects to be compiled such that sizeof(int) == 4, * sizeof(intptr_t) == sizeof(void*), sizeof(short) >= 2, * sizeof(char) == 1, sizeof(float) == 4, and sizeof(double) == 8. * So, on a 64-bit OS, Racket expects only `long' and `intptr_t' to change. **********************************************************************/ /* returns # 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->C: SCHEME_INT_VAL() * S->C offset: 0 * C->Scheme: scheme_make_integer() */ #define FOREIGN_uint8 (3) /* Type Name: uint8 * LibFfi type: ffi_type_uint8 * C type: Tuint8 * Predicate: SCHEME_INTP() * Scheme->C: SCHEME_UINT_VAL() * S->C offset: 0 * C->Scheme: scheme_make_integer_from_unsigned() */ #define FOREIGN_int16 (4) /* Type Name: int16 * LibFfi type: ffi_type_sint16 * C type: Tsint16 * Predicate: SCHEME_INTP() * Scheme->C: SCHEME_INT_VAL() * S->C offset: 0 * C->Scheme: scheme_make_integer() */ #define FOREIGN_uint16 (5) /* Type Name: uint16 * LibFfi type: ffi_type_uint16 * C type: Tuint16 * Predicate: SCHEME_INTP() * Scheme->C: SCHEME_UINT_VAL() * S->C offset: 0 * C->Scheme: scheme_make_integer_from_unsigned() */ /* Treats integers properly: */ #define FOREIGN_int32 (6) /* Type Name: int32 * LibFfi type: ffi_type_sint32 * C type: Tsint32 * Predicate: scheme_get_realint_val(,&aux) * Scheme->C: -none- (set by the predicate) * S->C offset: 0 * C->Scheme: scheme_make_realinteger_value() */ /* Treats integers properly: */ #define FOREIGN_uint32 (7) /* Type Name: uint32 * LibFfi type: ffi_type_uint32 * C type: Tuint32 * Predicate: scheme_get_unsigned_realint_val(,&aux) * Scheme->C: -none- (set by the predicate) * S->C offset: 0 * C->Scheme: scheme_make_realinteger_value_from_unsigned() */ #define FOREIGN_int64 (8) /* Type Name: int64 * LibFfi type: ffi_type_sint64 * C type: Tsint64 * Predicate: scheme_get_long_long_val(,&aux) * Scheme->C: -none- (set by the predicate) * S->C offset: 0 * C->Scheme: scheme_make_integer_value_from_long_long() */ #define FOREIGN_uint64 (9) /* Type Name: uint64 * LibFfi type: ffi_type_uint64 * C type: Tuint64 * Predicate: scheme_get_unsigned_long_long_val(,&aux) * Scheme->C: -none- (set by the predicate) * S->C offset: 0 * C->Scheme: scheme_make_integer_value_from_unsigned_long_long() */ /* 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->C: SCHEME_INT_VAL() * S->C offset: 0 * C->Scheme: scheme_make_integer() */ /* 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->C: SCHEME_UINT_VAL() * S->C offset: 0 * C->Scheme: scheme_make_integer_from_unsigned() */ #ifndef SIXTY_FOUR_BIT_LONGS #define ffi_type_smzlong ffi_type_sint32 #define ffi_type_umzlong ffi_type_uint32 #else /* SIXTY_FOUR_BIT_LONGS defined */ #define ffi_type_smzlong ffi_type_sint64 #define ffi_type_umzlong ffi_type_uint64 #endif /* SIXTY_FOUR_BIT_LONGS */ #ifndef SIXTY_FOUR_BIT_INTEGERS #define ffi_type_smzintptr ffi_type_sint32 #define ffi_type_umzintptr ffi_type_uint32 #else /* SIXTY_FOUR_BIT_INTEGERS defined */ #define ffi_type_smzintptr ffi_type_sint64 #define ffi_type_umzintptr ffi_type_uint64 #endif /* SIXTY_FOUR_BIT_INTEGERS */ /* This is what mzscheme defines as intptr, assuming fixnums: */ #define FOREIGN_fixnum (12) /* Type Name: fixnum * LibFfi type: ffi_type_smzintptr * C type: intptr_t * Predicate: SCHEME_INTP() * Scheme->C: SCHEME_INT_VAL() * S->C offset: 0 * C->Scheme: scheme_make_integer() */ /* This is what mzscheme defines as uintptr, assuming fixnums: */ #define FOREIGN_ufixnum (13) /* Type Name: ufixnum * LibFfi type: ffi_type_umzintptr * C type: uintptr_t * Predicate: SCHEME_INTP() * Scheme->C: SCHEME_UINT_VAL() * S->C offset: 0 * C->Scheme: scheme_make_integer_from_unsigned() */ #define FOREIGN_float (14) /* Type Name: float * LibFfi type: ffi_type_float * C type: float * Predicate: SCHEME_FLOATP() * Scheme->C: SCHEME_FLOAT_VAL() * S->C offset: 0 * C->Scheme: scheme_make_double() */ #define FOREIGN_double (15) /* Type Name: double * LibFfi type: ffi_type_double * C type: double * Predicate: SCHEME_FLOATP() * Scheme->C: SCHEME_FLOAT_VAL() * S->C offset: 0 * C->Scheme: scheme_make_double() */ /* 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->C: scheme_real_to_double() * S->C offset: 0 * C->Scheme: scheme_make_double() */ /* 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() * S->C offset: 0 * C->Scheme: (?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_gcpointer * C type: mzchar* * Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP() * Scheme->C: ucs4_string_or_null_to_ucs4_pointer() * S->C offset: 0 * C->Scheme: scheme_make_char_string_without_copying() */ #define FOREIGN_string_utf_16 (19) /* Type Name: string/utf-16 (string_utf_16) * LibFfi type: ffi_type_gcpointer * C type: unsigned short* * Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP() * Scheme->C: ucs4_string_or_null_to_utf16_pointer() * S->C offset: 0 * C->Scheme: utf16_pointer_to_ucs4_string() */ /* 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_gcpointer * C type: char* * Predicate: SCHEME_FALSEP()||SCHEME_BYTE_STRINGP() * Scheme->C: SCHEME_FALSEP()?NULL:SCHEME_BYTE_STR_VAL() * S->C offset: 0 * C->Scheme: (==NULL)?scheme_false:scheme_make_byte_string_without_copying() */ #define FOREIGN_path (21) /* Type Name: path * LibFfi type: ffi_type_gcpointer * C type: char* * Predicate: SCHEME_FALSEP()||SCHEME_PATH_STRINGP() * Scheme->C: SCHEME_FALSEP()?NULL:SCHEME_PATH_VAL(TO_PATH()) * S->C offset: 0 * C->Scheme: (==NULL)?scheme_false:scheme_make_path_without_copying() */ #define FOREIGN_symbol (22) /* Type Name: symbol * LibFfi type: ffi_type_pointer * C type: char* * Predicate: SCHEME_SYMBOLP() * Scheme->C: SCHEME_SYM_VAL() * S->C offset: 0 * C->Scheme: scheme_intern_symbol() */ /* 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->C: SCHEME_FFIANYPTR_VAL() * S->C offset: FFIANYPTR * C->Scheme: scheme_make_foreign_external_cpointer() */ #define FOREIGN_gcpointer (24) /* Type Name: gcpointer * LibFfi type: ffi_type_gcpointer * C type: void* * Predicate: SCHEME_FFIANYPTRP() * Scheme->C: SCHEME_FFIANYPTR_VAL() * S->C offset: FFIANYPTR * C->Scheme: scheme_make_foreign_cpointer() */ /* This is used for passing and Scheme_Object* value as is. Useful for * functions that know about Scheme_Object*s, like Racket's. */ #define FOREIGN_scheme (25) /* Type Name: scheme * LibFfi type: ffi_type_gcpointer * C type: Scheme_Object* * Predicate: 1 * Scheme->C: * S->C offset: 0 * C->Scheme: */ /* 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; intptr_t x_fixnum; uintptr_t 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) #define FOREIGN_array (28) #define FOREIGN_union (29) static int is_gcable_pointer(Scheme_Object *o) { return !SCHEME_CPTRP(o) || !(SCHEME_CPTR_FLAGS(o) & 0x1); } /*****************************************************************************/ /* 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) ((intptr_t)(((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) #define CTYPE_ARG_PRIMTYPE(x) ((CTYPE_PRIMLABEL(x) == FOREIGN_array) ? &ffi_type_pointer : CTYPE_PRIMTYPE(x)) /* 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(intptr_t); case FOREIGN_ufixnum: return sizeof(uintptr_t); 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 and arrays */ 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); } void free_libffi_type_with_alignment(void *ignored, void *p) { int i; for (i = 0; ((ffi_type*)p)->elements[i]; i++) { free(((ffi_type*)p)->elements[i]); } free_libffi_type(ignored, 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)) { #if defined(WINDOWS_DYNAMIC_LOAD) && !defined(_WIN64) return FFI_SYSV; #else scheme_signal_error("%s: ABI not implemented: %V", who, sym); #endif } else if (SAME_OBJ(sym, stdcall_sym)) { #if defined(WINDOWS_DYNAMIC_LOAD) && !defined(_WIN64) 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 alignment]) -> 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 Racket. */ #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, with_alignment; 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); if (argc > 2) { if (!SCHEME_FALSEP(argv[2])) { if (!SAME_OBJ(argv[2], scheme_make_integer(1)) && !SAME_OBJ(argv[2], scheme_make_integer(2)) && !SAME_OBJ(argv[2], scheme_make_integer(4)) && !SAME_OBJ(argv[2], scheme_make_integer(8)) && !SAME_OBJ(argv[2], scheme_make_integer(16))) scheme_wrong_type(MYNAME, "1, 2, 4, 8, 16, or #f", 2, argc, argv); with_alignment = SCHEME_INT_VAL(argv[2]); } else with_alignment = 0; } else with_alignment = 0; /* allocate the type elements */ elements = malloc((nargs+1) * sizeof(ffi_type*)); elements[nargs] = NULL; for (i=0, p=argv[0]; ialignment) elements[i]->alignment = with_alignment; } } /* 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); if (with_alignment) scheme_register_finalizer(type, free_libffi_type_with_alignment, libffi_type, NULL, NULL); else scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL); return (Scheme_Object*)type; } #undef MYNAME /*****************************************************************************/ /* array types */ /* (make-array-type type len) -> ctype */ /* This creates a new primitive type that is an array. An array is the * same as a cpointer as an argument, but it behave differently within * a struct or for allocation. Marshaling to lists or whatever should * be done in Racket. */ #define MYNAME "make-array-type" static Scheme_Object *foreign_make_array_type(int argc, Scheme_Object *argv[]) { Scheme_Object *base, *basetype; GC_CAN_IGNORE ffi_type *libffi_type, **elements; ctype_struct *type; intptr_t len; if (NULL == (base = get_ctype_base(argv[0]))) scheme_wrong_type(MYNAME, "C-type", 0, argc, argv); if (!scheme_get_int_val(argv[1], &len) || (len < 0)) scheme_wrong_type(MYNAME, "pointer-sized nonnegative exact integer", 1, argc, argv); /* libffi doesn't seem to support array types, but we try to make libffi work anyway by making a structure type that is used when an array appears as a struct field. If the array size is 4 or less, or if the total size is 32 bytes or less, then we make a full `elements' array, because the x86_64 ABI always shifts to memory mode after 32 bytes. */ /* Allocate the new libffi type object, which is only provided to libffi as a type for a structure field. When a FOREIGN_array type is used for a function argument or result, it is replaced with FOREIGN_pointer. We put FFI_TYPE_STRUCT in libffi_type->type and make an elements array that contains a single instance of the element type... which seems to work ok so far. */ libffi_type = malloc(sizeof(ffi_type)); libffi_type->size = CTYPE_PRIMTYPE(base)->size * len; libffi_type->alignment = CTYPE_PRIMTYPE(base)->alignment; libffi_type->type = FFI_TYPE_STRUCT; if ((libffi_type->size <= 32) || (len <= 4)) { int i; elements = malloc((len + 1) * sizeof(ffi_type*)); for (i = 0; i < len; i++) { elements[i] = CTYPE_PRIMTYPE(base); } elements[len] = NULL; } else { elements = malloc(2 * sizeof(ffi_type*)); elements[0] = CTYPE_PRIMTYPE(base); elements[1] = NULL; } libffi_type->elements = elements; basetype = scheme_make_vector(2, argv[0]); SCHEME_VEC_ELS(basetype)[1] = argv[1]; type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); type->so.type = ctype_tag; type->basetype = (basetype); type->scheme_to_c = ((Scheme_Object*)libffi_type); type->c_to_scheme = ((Scheme_Object*)FOREIGN_array); scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL); return (Scheme_Object*)type; } #undef MYNAME /*****************************************************************************/ /* union types */ /* (make-union-type type ...+) -> ctype */ /* This creates a new primitive type that is a union. All unions * behave like structs. Marshaling to lists or whatever should * be done in Racket. */ #define MYNAME "make-union-type" static Scheme_Object *foreign_make_union_type(int argc, Scheme_Object *argv[]) { Scheme_Object *base, *basetype; GC_CAN_IGNORE ffi_type *libffi_type, **elements; ctype_struct *type; int i, align = 1, a, sz = 0; elements = malloc((argc + 1) * sizeof(ffi_type*)); /* find max required alignment and size: */ for (i = 0; i < argc; i++) { if (NULL == (base = get_ctype_base(argv[i]))) { free(elements); scheme_wrong_type(MYNAME, "C-type", i, argc, argv); } a = CTYPE_PRIMTYPE(base)->alignment; if (a > align) align = a; a = CTYPE_PRIMTYPE(base)->size; if (sz < a) sz = a; elements[i] = CTYPE_PRIMTYPE(base); } elements[argc] = NULL; /* round size up to alignment: */ if ((sz % align) != 0) { sz += (align - (sz % align)); } /* libffi doesn't seem to support union types, but we try to make libffi work anyway by making a structure type. We put all the element types in the `elements' array, because their shapes may affect argument passing. */ /* Allocate the new libffi type object. */ libffi_type = malloc(sizeof(ffi_type)); libffi_type->size = sz; libffi_type->alignment = align; libffi_type->type = FFI_TYPE_STRUCT; libffi_type->elements = elements; basetype = scheme_box(scheme_build_list(argc, argv)); type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); type->so.type = ctype_tag; type->basetype = (basetype); type->scheme_to_c = ((Scheme_Object*)libffi_type); type->c_to_scheme = ((Scheme_Object*)FOREIGN_union); 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; NON_GCBALE_PTR(void) callback; Scheme_Object* proc; Scheme_Object* itypes; Scheme_Object* otype; Scheme_Object* sync; } 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->proc); gcMARK(s->itypes); gcMARK(s->otype); gcMARK(s->sync); return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct)); } int ffi_callback_FIXUP(void *p) { ffi_callback_struct *s = (ffi_callback_struct *)p; gcFIXUP(s->proc); gcFIXUP(s->itypes); gcFIXUP(s->otype); gcFIXUP(s->sync); return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct)); } END_XFORM_SKIP; #endif /* The sync field: NULL => non-atomic mode #t => atomic mode, no sync proc proc => non-atomic mode, sync proc (box proc) => atomic mode, sync proc */ /*****************************************************************************/ /* 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) \ (SCHEME_CPTRP(x) && SCHEME_CPTR_HAS_OFFSET(x)) #define scheme_make_foreign_cpointer(x) \ ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL)) #define scheme_make_foreign_offset_cpointer(x, delta) \ ((delta == 0) ? scheme_make_foreign_cpointer(x) : scheme_make_offset_cptr(x,delta,NULL)) #define scheme_make_foreign_external_cpointer(x) \ ((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL)) #define scheme_make_foreign_offset_external_cpointer(x, delta) \ ((delta == 0) ? scheme_make_foreign_external_cpointer(x) : scheme_make_offset_external_cptr(x,delta,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 void *scheme_extract_pointer(Scheme_Object *v) { return SCHEME_FFIANYPTR_VAL(v); } /*****************************************************************************/ /* 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,gcsrc) c_to_scheme(typ,src,delta,argsloc,gcsrc) #define REF_CTYPE(ctype) (((sizeof(ctype)Scheme", "C-type", 0, 1, &type); if (CTYPE_USERP(type)) { res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc, gcsrc); 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(intptr_t)); case FOREIGN_ufixnum: return scheme_make_integer_from_unsigned(REF_CTYPE(uintptr_t)); case FOREIGN_float: return scheme_make_double(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: case FOREIGN_array: case FOREIGN_union: if (gcsrc) return scheme_make_foreign_offset_cpointer(src, delta); else return scheme_make_foreign_offset_external_cpointer(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 or array) is returned, and the * basetype_p is set to the corrsponding number tag. If basetype_p is NULL, * then a struct or array value will be *copied* into dst. */ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta, Scheme_Object *val, intptr_t *basetype_p, intptr_t *_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)C","int8",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_uint8: # ifdef SCHEME_BIG_ENDIAN if (sizeof(Tuint8)C","uint8",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_int16: # ifdef SCHEME_BIG_ENDIAN if (sizeof(Tsint16)C","int16",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_uint16: # ifdef SCHEME_BIG_ENDIAN if (sizeof(Tuint16)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)C","fixint",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_ufixint: # ifdef SCHEME_BIG_ENDIAN if (sizeof(Tuint32)C","ufixint",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_fixnum: # ifdef SCHEME_BIG_ENDIAN if (sizeof(intptr_t)C","fixnum",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_ufixnum: # ifdef SCHEME_BIG_ENDIAN if (sizeof(uintptr_t)C","ufixnum",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_float: # ifdef SCHEME_BIG_ENDIAN if (sizeof(float)C","float",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_double: # ifdef SCHEME_BIG_ENDIAN if (sizeof(double)C","double",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_doubleS: # ifdef SCHEME_BIG_ENDIAN if (sizeof(double)C","double*",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_bool: # ifdef SCHEME_BIG_ENDIAN if (sizeof(int)C","bool",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_string_ucs_4: # ifdef SCHEME_BIG_ENDIAN if (sizeof(mzchar*)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*)C","string/utf-16",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_bytes: # ifdef SCHEME_BIG_ENDIAN if (sizeof(char*)C","bytes",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_path: # ifdef SCHEME_BIG_ENDIAN if (sizeof(char*)C","path",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_symbol: # ifdef SCHEME_BIG_ENDIAN if (sizeof(char*)C","symbol",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_pointer: # ifdef SCHEME_BIG_ENDIAN if (sizeof(void*)C","pointer",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_gcpointer: # ifdef SCHEME_BIG_ENDIAN if (sizeof(void*)C","gcpointer",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_scheme: # ifdef SCHEME_BIG_ENDIAN if (sizeof(Scheme_Object*)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: case FOREIGN_array: case FOREIGN_union: if (!SCHEME_FFIANYPTRP(val)) scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val); { void* p = SCHEME_FFIANYPTR_VAL(val); intptr_t 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 = CTYPE_PRIMLABEL(type); if (_offset && is_gcable_pointer(val)) { *_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 */ int must_list = 0; Scheme_Object *l = argv[0], *p; while (!SAME_OBJ(l, scheme_null)) { if (SCHEME_PAIRP(l)) { p = SCHEME_CAR(l); l = SCHEME_CDR(l); must_list = 1;} else if (must_list) { p = scheme_false; l = scheme_null; } else { p = l; l = scheme_null; } if (!SCHEME_SYMBOLP(p)) { scheme_wrong_type(MYNAME, "symbol or 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, "C type symbol or 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(int); /* avoid sizeof(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, failok=0; intptr_t size=0, num=0; void *from = NULL, *res = NULL; intptr_t foff = 0; Scheme_Object *mode = NULL, *a, *base = NULL; void *(*mf)(size_t); for (i=0; i 2) { if (SCHEME_CTYPEP(argv[2])) { intptr_t 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[]) { intptr_t 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_INTPTR_T_TYPE_STR, 1, argc, argv); } if (argc > 2) { if (SCHEME_CTYPEP(argv[2])) { intptr_t 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; intptr_t 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_INTPTR_T_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 (!(icpointer" static Scheme_Object *foreign_vector_to_cpointer(int argc, Scheme_Object *argv[]) { if (!SCHEME_VECTORP(argv[0])) scheme_wrong_type(MYNAME, "vector", 0, argc, argv); return scheme_make_offset_cptr(argv[0], (intptr_t)SCHEME_VEC_ELS((Scheme_Object *)0x0), NULL); } #undef MYNAME #define MYNAME "flvector->cpointer" static Scheme_Object *foreign_flvector_to_cpointer(int argc, Scheme_Object *argv[]) { if (!SCHEME_FLVECTORP(argv[0])) scheme_wrong_type(MYNAME, "flvector", 0, argc, argv); return scheme_make_offset_cptr(argv[0], (intptr_t)SCHEME_FLVEC_ELS((Scheme_Object *)0x0), NULL); } #undef MYNAME #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; intptr_t delta; int gcsrc=1; 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 (!is_gcable_pointer(argv[0])) gcsrc = 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 = (intptr_t)&(((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, "fixnum", 3, argc, argv); delta += SCHEME_INT_VAL(argv[3]); } else if (argc > 2) { if (!SCHEME_INTP(argv[2])) scheme_wrong_type(MYNAME, "fixnum", 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, gcsrc); } #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; intptr_t 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, "fixnum", 3, argc, argv); delta += SCHEME_INT_VAL(argv[3]); } else if (argc > 3) { if (!SCHEME_INTP(argv[2])) scheme_wrong_type(MYNAME, "fixnum", 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.) */ intptr_t 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 intptr_t 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 Racket code while the GC is working leads to subtle bugs, so *** this is implemented now in Racket 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)(); #ifdef MZ_USE_PLACES typedef struct FFI_Orig_Place_Call { ffi_cif *cif; VoidFun proc; void *p; void **avalues; mzrt_sema *sema; struct FFI_Orig_Place_Call *next; } FFI_Orig_Place_Call; static mzrt_mutex *orig_place_mutex; static FFI_Orig_Place_Call *orig_place_calls; static void *orig_place_signal_handle; void ffi_call_in_orig_place(ffi_cif *cif, VoidFun proc, void *p, void **avalues) XFORM_SKIP_PROC { if (scheme_current_place_id == 0) { ffi_call(cif, proc, p, avalues); } else { FFI_Orig_Place_Call *todo; todo = (FFI_Orig_Place_Call *)malloc(sizeof(FFI_Orig_Place_Call)); todo->cif = cif; todo->proc = proc; todo->p = p; todo->avalues = avalues; mzrt_sema_create(&todo->sema, 0); mzrt_mutex_lock(orig_place_mutex); todo->next = orig_place_calls; orig_place_calls = todo; mzrt_mutex_unlock(orig_place_mutex); scheme_signal_received_at(orig_place_signal_handle); mzrt_sema_wait(todo->sema); mzrt_sema_destroy(todo->sema); free(todo); } } #endif 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]); intptr_t cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); int save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]); #ifdef MZ_USE_PLACES int orig_place = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[7]); #endif 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 * Racket 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; GC_CAN_IGNORE ForeignAny stack_ivals[MAX_QUICK_ARGS]; void *stack_avalues[MAX_QUICK_ARGS]; intptr_t stack_offsets[MAX_QUICK_ARGS]; int i; intptr_t 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_atomic(nargs * sizeof(intptr_t)); } /* iterate on input values and types */ for (i=0; isize); 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; isize); free(p); p = newp; break; case FOREIGN_array: /* array as result is treated as a pointer, so adjust `p' to make C2SCHEME work right */ p = *(void **)p; break; } return C2SCHEME(otype, p, 0, 1, 1); } /* see below */ void free_fficall_data(void *ignored, void *p) { free(((ffi_cif*)p)->arg_types); free(p); } static Scheme_Object *ffi_name_prefix = NULL; /* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place?]) -> (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[]) { Scheme_Object *itypes = argv[1]; Scheme_Object *otype = argv[2]; Scheme_Object *obj, *data, *p, *base; ffi_abi abi; intptr_t ooff; GC_CAN_IGNORE ffi_type *rtype, **atypes; GC_CAN_IGNORE ffi_cif *cif; int i, nargs, save_errno; #ifdef MZ_USE_PLACES int orig_place; # define FFI_CALL_VEC_SIZE 8 #else # define FFI_CALL_VEC_SIZE 7 #endif 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_ARG_PRIMTYPE(base); abi = GET_ABI(MYNAME,3); if (argc > 4) { save_errno = -1; if (SCHEME_FALSEP(argv[4])) save_errno = 0; else if (SCHEME_SYMBOLP(argv[4]) && !SCHEME_SYM_WEIRDP(argv[4])) { if (!strcmp(SCHEME_SYM_VAL(argv[4]), "posix")) save_errno = 1; else if (!strcmp(SCHEME_SYM_VAL(argv[4]), "windows")) save_errno = 2; } if (save_errno == -1) { scheme_wrong_type(MYNAME, "'posix, 'windows, or #f", 4, argc, argv); } } else save_errno = 0; #ifdef MZ_USE_PLACES if (argc > 5) { orig_place = SCHEME_TRUEP(argv[5]); } else orig_place = 0; #endif atypes = malloc(nargs * sizeof(ffi_type*)); for (i=0, p=itypes; iname : "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_VEC_ELS(data)[6] = scheme_make_integer(save_errno); #ifdef MZ_USE_PLACES SCHEME_VEC_ELS(data)[7] = (orig_place ? scheme_true : scheme_false); #endif 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 /*****************************************************************************/ /* Racket callbacks */ typedef void (*ffi_callback_t)(ffi_cif* cif, void* resultp, void** args, void *userdata); static ffi_callback_struct *extract_ffi_callback(void *userdata) XFORM_SKIP_PROC { ffi_callback_struct *data; #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 return data; } 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, *t; data = extract_ffi_callback(userdata); if (argc <= MAX_QUICK_ARGS) argv = argv_stack; else argv = scheme_malloc(argc * sizeof(Scheme_Object*)); if (data->sync && !SCHEME_PROCP(data->sync)) scheme_start_in_scheduler(); for (i=0, p=data->itypes; iproc, argc, argv); SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1); if (data->sync && !SCHEME_PROCP(data->sync)) scheme_end_in_scheduler(); } #ifdef MZ_USE_MZRT /* When OS-level thread support is avaiable, support callbacks in foreign threads that are executed on the main Racket thread. */ typedef struct Queued_Callback { ffi_cif* cif; void* resultp; void** args; void *userdata; mzrt_sema *sema; int called; struct Queued_Callback *next; } Queued_Callback; typedef struct FFI_Sync_Queue { Queued_Callback *callbacks; /* malloc()ed list */ mzrt_mutex *lock; mzrt_thread_id orig_thread; void *sig_hand; } FFI_Sync_Queue; THREAD_LOCAL_DECL(static struct FFI_Sync_Queue *ffi_sync_queue); static Scheme_Object *callback_thunk(void *_qc, int argc, Scheme_Object *argv[]) { Queued_Callback *qc = (Queued_Callback *)_qc; if (qc->called) scheme_raise_exn(MZEXN_FAIL_CONTRACT, "callback thunk for synchronization has already been called"); qc->called = 1; ffi_do_callback(qc->cif, qc->resultp, qc->args, qc->userdata); mzrt_sema_post(qc->sema); return scheme_void; } void scheme_check_foreign_work(void) { GC_CAN_IGNORE Queued_Callback *qc; ffi_callback_struct *data; Scheme_Object *a[1], *proc; if (ffi_sync_queue) { do { mzrt_mutex_lock(ffi_sync_queue->lock); qc = ffi_sync_queue->callbacks; if (qc) ffi_sync_queue->callbacks = qc->next; mzrt_mutex_unlock(ffi_sync_queue->lock); if (qc) { qc->next = NULL; data = extract_ffi_callback(qc->userdata); proc = scheme_make_closed_prim_w_arity(callback_thunk, (void *)qc, "callback-thunk", 0, 0); a[0] = proc; proc = data->sync; if (SCHEME_BOXP(proc)) proc = SCHEME_BOX_VAL(proc); scheme_start_in_scheduler(); _scheme_apply(proc, 1, a); scheme_end_in_scheduler(); } } while (qc); } #ifdef MZ_USE_PLACES if ((scheme_current_place_id == 0) && orig_place_mutex) { FFI_Orig_Place_Call *todo, *next; mzrt_mutex_lock(orig_place_mutex); todo = orig_place_calls; orig_place_calls = NULL; mzrt_mutex_unlock(orig_place_mutex); while (todo) { ffi_call(todo->cif, todo->proc, todo->p, todo->avalues); next = todo->next; mzrt_sema_post(todo->sema); todo = next; } } #endif } #endif void ffi_queue_callback(ffi_cif* cif, void* resultp, void** args, void *userdata) XFORM_SKIP_PROC { #ifdef MZ_USE_MZRT /* This function must not refer to any GCable address, not even temporarily, because a GC may occur concurrent to this function if it's in another thread. */ FFI_Sync_Queue *queue; queue = (FFI_Sync_Queue *)((void **)userdata)[1]; userdata = ((void **)userdata)[0]; if (queue->orig_thread != mz_proc_thread_self()) { Queued_Callback *qc; mzrt_sema *sema; mzrt_sema_create(&sema, 0); qc = (Queued_Callback *)malloc(sizeof(Queued_Callback)); qc->cif = cif; qc->resultp = resultp; qc->args = args; qc->userdata = userdata; qc->sema = sema; qc->called = 0; mzrt_mutex_lock(queue->lock); qc->next = queue->callbacks; queue->callbacks = qc; mzrt_mutex_unlock(queue->lock); scheme_signal_received_at(queue->sig_hand); /* wait for the callback to be invoked in the main thread */ mzrt_sema_wait(sema); mzrt_sema_destroy(sema); free(qc); return; } #endif ffi_do_callback(cif, resultp, args, userdata); } /* 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); } #ifdef MZ_USE_MZRT void free_cl_cif_queue_args(void *ignored, void *p) { void *data = ((closure_and_cif*)p)->data; void **q = (void **)data; data = q[0]; free(q); #ifdef MZ_PRECISE_GC GC_free_immobile_box((void**)data); #endif scheme_free_code(p); } #endif /* (ffi-callback scheme-proc in-types out-type [abi atomic? sync]) -> 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 *sync; Scheme_Object *p, *base; ffi_abi abi; int is_atomic; 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 Racket 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 : | \-----> Racket 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; GC_CAN_IGNORE ffi_callback_t do_callback; GC_CAN_IGNORE void *callback_data; #ifdef MZ_USE_MZRT int keep_queue = 0; #endif 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_ARG_PRIMTYPE(base); abi = GET_ABI(MYNAME,3); is_atomic = ((argc > 4) && SCHEME_TRUEP(argv[4])); sync = (is_atomic ? scheme_true : NULL); if (argc > 5) (void)scheme_check_proc_arity2(MYNAME, 1, 5, argc, argv, 1); if (((argc > 5) && SCHEME_TRUEP(argv[5]))) { #ifdef MZ_USE_MZRT if (!ffi_sync_queue) { mzrt_thread_id tid; void *sig_hand; ffi_sync_queue = (FFI_Sync_Queue *)malloc(sizeof(FFI_Sync_Queue)); tid = mz_proc_thread_self(); ffi_sync_queue->orig_thread = tid; mzrt_mutex_create(&ffi_sync_queue->lock); sig_hand = scheme_get_signal_handle(); ffi_sync_queue->sig_hand = sig_hand; ffi_sync_queue->callbacks = NULL; } sync = argv[5]; if (is_atomic) sync = scheme_box(sync); keep_queue = 1; #endif do_callback = ffi_queue_callback; } else do_callback = ffi_do_callback; /* 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; iso.type = ffi_callback_tag; data->callback = (cl_cif_args); data->proc = (argv[0]); data->itypes = (argv[1]); data->otype = (argv[2]); data->sync = (sync); # ifdef MZ_PRECISE_GC { /* put data in immobile, weak box */ GC_CAN_IGNORE void **tmp; tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0, 1)); callback_data = (struct immobile_box*)tmp; } # else /* MZ_PRECISE_GC undefined */ callback_data = (void*)data; # endif /* MZ_PRECISE_GC */ #ifdef MZ_USE_MZRT if (keep_queue) { /* For ffi_queue_callback(), add a level of indirection in `data' to hold the place-specific `ffi_sync_queue'. Use `free_cl_cif_data_args' to clean up this extra level. */ GC_CAN_IGNORE void **tmp; tmp = (void **)malloc(sizeof(void*) * 2); tmp[0] = callback_data; tmp[1] = ffi_sync_queue; callback_data = (void *)tmp; } #endif cl_cif_args->data = callback_data; if (ffi_prep_closure(cl, cif, do_callback, (void*)(cl_cif_args->data)) != FFI_OK) scheme_signal_error ("internal error: ffi_prep_closure did not return FFI_OK"); #ifdef MZ_USE_MZRT if (keep_queue) scheme_register_finalizer(data, free_cl_cif_queue_args, cl_cif_args, NULL, NULL); else #endif scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL); return (Scheme_Object*)data; } #undef MYNAME /*****************************************************************************/ static void save_errno_values(int kind) { Scheme_Thread *p = scheme_current_thread; if (kind == 2) { intptr_t v = 0; # ifdef WINDOWS_DYNAMIC_LOAD v = GetLastError(); # endif /* WINDOWS_DYNAMIC_LOAD */ p->saved_errno = v; return; } p->saved_errno = errno; } #define MYNAME "saved-errno" static Scheme_Object *foreign_saved_errno(int argc, Scheme_Object *argv[]) { Scheme_Thread *p = scheme_current_thread; return scheme_make_integer_value(p->saved_errno); } #undef MYNAME #define MYNAME "lookup-errno" static Scheme_Object *foreign_lookup_errno(int argc, Scheme_Object *argv[]) { Scheme_Object *v = argv[0]; if (SCHEME_SYMBOLP(v) && !SCHEME_SYM_WEIRDP(v)) { if (!strcmp("EINTR", SCHEME_SYM_VAL(v))) return scheme_make_integer(EINTR); if (!strcmp("EEXIST", SCHEME_SYM_VAL(v))) return scheme_make_integer(EEXIST); if (!strcmp("EAGAIN", SCHEME_SYM_VAL(v))) return scheme_make_integer(EAGAIN); } scheme_wrong_type(MYNAME, "'EINTR, 'EEXIST, or 'EAGAIN",0, argc, argv); return NULL; } #undef MYNAME /*****************************************************************************/ /* (make-stubborn-will-executor) -> # */ #define MYNAME "make-stubborn-will-executor" static Scheme_Object *foreign_make_stubborn_will_executor(int argc, Scheme_Object *argv[]) { return scheme_make_stubborn_will_executor(); } #undef MYNAME /* (make-late-weak-box val) -> # */ #define MYNAME "make-late-weak-box" static Scheme_Object *foreign_make_late_weak_box(int argc, Scheme_Object *argv[]) { return scheme_make_late_weak_box(argv[0]); } #undef MYNAME /* (make-late-weak-hasheq) -> # */ #define MYNAME "make-late-weak-hasheq" static Scheme_Object *foreign_make_late_weak_hasheq(int argc, Scheme_Object *argv[]) { return (Scheme_Object *)scheme_make_bucket_table(20, SCHEME_hash_late_weak_ptr); } #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, "#", 0, 1); } else { scheme_print_bytes(pp, "#", 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_obj_tag = scheme_make_type(""); ctype_tag = scheme_make_type(""); ffi_callback_tag = scheme_make_type(""); # 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(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"); MZ_REGISTER_STATIC(ffi_name_prefix); ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:"); } void scheme_init_foreign_places() { MZ_REGISTER_STATIC(opened_libs); opened_libs = scheme_make_hash_table(SCHEME_hash_string); #ifdef MZ_USE_PLACES if (!orig_place_mutex) { mzrt_mutex_create(&orig_place_mutex); orig_place_signal_handle = scheme_get_signal_handle(); } #endif } 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, 3), 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, 3), menv); scheme_add_global("make-array-type", scheme_make_prim_w_arity(foreign_make_array_type, "make-array-type", 2, 2), menv); scheme_add_global("make-union-type", scheme_make_prim_w_arity(foreign_make_union_type, "make-union-type", 1, -1), 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("vector->cpointer", scheme_make_prim_w_arity(foreign_vector_to_cpointer, "vector->cpointer", 1, 1), menv); scheme_add_global("flvector->cpointer", scheme_make_prim_w_arity(foreign_flvector_to_cpointer, "flvector->cpointer", 1, 1), 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, 6), menv); scheme_add_global("ffi-callback", scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 6), menv); scheme_add_global("saved-errno", scheme_make_prim_w_arity(foreign_saved_errno, "saved-errno", 0, 0), menv); scheme_add_global("lookup-errno", scheme_make_prim_w_arity(foreign_lookup_errno, "lookup-errno", 1, 1), menv); scheme_add_global("make-stubborn-will-executor", scheme_make_prim_w_arity(foreign_make_stubborn_will_executor, "make-stubborn-will-executor", 0, 0), menv); scheme_add_global("make-late-weak-box", scheme_make_prim_w_arity(foreign_make_late_weak_box, "make-late-weak-box", 1, 1), menv); scheme_add_global("make-late-weak-hasheq", scheme_make_prim_w_arity(foreign_make_late_weak_hasheq, "make-late-weak-hasheq", 0, 0), 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_smzintptr)); 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_umzintptr)); 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_gcpointer)); 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_gcpointer)); 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_gcpointer)); 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_gcpointer)); 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); } /*****************************************************************************/ #else /* DONT_USE_FOREIGN */ static Scheme_Object *unimplemented(int argc, Scheme_Object **argv, Scheme_Object *who) { scheme_signal_error("%s: foreign interface not supported for this platform", ((Scheme_Primitive_Proc *)who)->name); return NULL; } static Scheme_Object *foreign_compiler_sizeof(int argc, Scheme_Object **argv) { return scheme_make_integer(4); } static Scheme_Object *foreign_make_ctype(int argc, Scheme_Object **argv) { return scheme_false; } static Scheme_Object *foreign_make_stubborn_will_executor(int argc, Scheme_Object *argv[]) { return scheme_make_stubborn_will_executor(); } void scheme_init_foreign(Scheme_Env *env) { /* Create a dummy module. */ Scheme_Env *menv; menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); scheme_add_global("ffi-lib?", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-lib?", 1, 1), menv); scheme_add_global("ffi-lib", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-lib", 1, 3), menv); scheme_add_global("ffi-lib-name", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-lib-name", 1, 1), menv); scheme_add_global("ffi-obj?", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-obj?", 1, 1), menv); scheme_add_global("ffi-obj", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-obj", 2, 2), menv); scheme_add_global("ffi-obj-lib", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-obj-lib", 1, 1), menv); scheme_add_global("ffi-obj-name", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-obj-name", 1, 1), menv); scheme_add_global("ctype?", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ctype?", 1, 1), menv); scheme_add_global("ctype-basetype", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ctype-basetype", 1, 1), menv); scheme_add_global("ctype-scheme->c", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ctype-scheme->c", 1, 1), menv); scheme_add_global("ctype-c->scheme", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ctype-c->scheme", 1, 1), menv); scheme_add_global("make-ctype", scheme_make_prim_w_arity((Scheme_Prim *)foreign_make_ctype, "make-ctype", 3, 3), menv); scheme_add_global("make-cstruct-type", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-cstruct-type", 1, 3), menv); scheme_add_global("make-array-type", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-array-type", 2, 2), menv); scheme_add_global("make-union-type", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-union-type", 1, -1), menv); scheme_add_global("ffi-callback?", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-callback?", 1, 1), menv); scheme_add_global("cpointer?", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "cpointer?", 1, 1), menv); scheme_add_global("cpointer-tag", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "cpointer-tag", 1, 1), menv); scheme_add_global("set-cpointer-tag!", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "set-cpointer-tag!", 2, 2), menv); scheme_add_global("ctype-sizeof", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ctype-sizeof", 1, 1), menv); scheme_add_global("ctype-alignof", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ctype-alignof", 1, 1), menv); scheme_add_global("compiler-sizeof", scheme_make_prim_w_arity((Scheme_Prim *)foreign_compiler_sizeof, "compiler-sizeof", 1, 1), menv); scheme_add_global("malloc", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "malloc", 1, 5), menv); scheme_add_global("end-stubborn-change", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "end-stubborn-change", 1, 1), menv); scheme_add_global("free", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "free", 1, 1), menv); scheme_add_global("malloc-immobile-cell", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "malloc-immobile-cell", 1, 1), menv); scheme_add_global("free-immobile-cell", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "free-immobile-cell", 1, 1), menv); scheme_add_global("ptr-add", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ptr-add", 2, 3), menv); scheme_add_global("ptr-add!", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ptr-add!", 2, 3), menv); scheme_add_global("offset-ptr?", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "offset-ptr?", 1, 1), menv); scheme_add_global("ptr-offset", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ptr-offset", 1, 1), menv); scheme_add_global("set-ptr-offset!", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "set-ptr-offset!", 2, 3), menv); scheme_add_global("vector->cpointer", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "vector->cpointer", 1, 1), menv); scheme_add_global("flvector->cpointer", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "flvector->cpointer", 1, 1), menv); scheme_add_global("memset", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "memset", 3, 5), menv); scheme_add_global("memmove", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "memmove", 3, 6), menv); scheme_add_global("memcpy", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "memcpy", 3, 6), menv); scheme_add_global("ptr-ref", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ptr-ref", 2, 4), menv); scheme_add_global("ptr-set!", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ptr-set!", 3, 5), menv); scheme_add_global("ptr-equal?", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ptr-equal?", 2, 2), menv); scheme_add_global("make-sized-byte-string", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-sized-byte-string", 2, 2), menv); scheme_add_global("ffi-call", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-call", 3, 6), menv); scheme_add_global("ffi-callback", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-callback", 3, 6), menv); scheme_add_global("saved-errno", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "saved-errno", 0, 0), menv); scheme_add_global("lookup-errno", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "lookup-errno", 1, 1), menv); scheme_add_global("make-stubborn-will-executor", scheme_make_prim_w_arity((Scheme_Prim *)foreign_make_stubborn_will_executor, "make-stubborn-will-executor", 0, 0), menv); scheme_add_global("make-late-weak-box", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-late-weak-box", 1, 1), menv); scheme_add_global("make-late-weak-hasheq", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-late-weak-hasheq", 0, 0), menv); scheme_add_global("_void", scheme_false, menv); scheme_add_global("_int8", scheme_false, menv); scheme_add_global("_uint8", scheme_false, menv); scheme_add_global("_int16", scheme_false, menv); scheme_add_global("_uint16", scheme_false, menv); scheme_add_global("_int32", scheme_false, menv); scheme_add_global("_uint32", scheme_false, menv); scheme_add_global("_int64", scheme_false, menv); scheme_add_global("_uint64", scheme_false, menv); scheme_add_global("_fixint", scheme_false, menv); scheme_add_global("_ufixint", scheme_false, menv); scheme_add_global("_fixnum", scheme_false, menv); scheme_add_global("_ufixnum", scheme_false, menv); scheme_add_global("_float", scheme_false, menv); scheme_add_global("_double", scheme_false, menv); scheme_add_global("_double*", scheme_false, menv); scheme_add_global("_bool", scheme_false, menv); scheme_add_global("_string/ucs-4", scheme_false, menv); scheme_add_global("_string/utf-16", scheme_false, menv); scheme_add_global("_bytes", scheme_false, menv); scheme_add_global("_path", scheme_false, menv); scheme_add_global("_symbol", scheme_false, menv); scheme_add_global("_pointer", scheme_false, menv); scheme_add_global("_gcpointer", scheme_false, menv); scheme_add_global("_scheme", scheme_false, menv); scheme_add_global("_fpointer", scheme_false, menv); scheme_finish_primitive_module(menv); scheme_protect_primitive_provide(menv, NULL); } #endif