2240 lines
79 KiB
C
Executable File
2240 lines
79 KiB
C
Executable File
#!/bin/sh
|
|
#| -*- C -*-
|
|
exec racket "$0" > `echo "$0" | sed 's/rktc$/c/'` "$0"
|
|
|#
|
|
|
|
#lang scribble/text
|
|
|
|
@(require "rktc-utils.ss")
|
|
|
|
@header{foreign.rktc}
|
|
|
|
#include "schpriv.h"
|
|
#include <errno.h>
|
|
|
|
@@@IFNDEF{WINDOWS_DYNAMIC_LOAD}{
|
|
|
|
# include <dlfcn.h>
|
|
|
|
# if SIZEOF_CHAR == 1
|
|
typedef signed char Tsint8;
|
|
typedef unsigned char Tuint8;
|
|
# else
|
|
# error "configuration error, please contact PLT (int8)"
|
|
# endif
|
|
|
|
# if SIZEOF_SHORT == 2
|
|
typedef signed short Tsint16;
|
|
typedef unsigned short Tuint16;
|
|
# elif SIZEOF_INT == 2
|
|
typedef signed int Tsint16;
|
|
typedef unsigned int Tuint16;
|
|
# else
|
|
# error "configuration error, please contact PLT (int16)"
|
|
# endif
|
|
|
|
# if SIZEOF_INT == 4
|
|
typedef signed int Tsint32;
|
|
typedef unsigned int Tuint32;
|
|
# elif SIZEOF_LONG == 4
|
|
typedef signed long Tsint32;
|
|
typedef unsigned long Tuint32;
|
|
# else
|
|
# error "configuration error, please contact PLT (int32)"
|
|
# endif
|
|
|
|
# if SIZEOF_LONG == 8
|
|
typedef signed long Tsint64;
|
|
typedef unsigned long Tuint64;
|
|
# elif SIZEOF_LONG_LONG == 8
|
|
typedef signed long long Tsint64;
|
|
typedef unsigned long long Tuint64;
|
|
# else
|
|
# error "configuration error, please contact PLT (int64)"
|
|
# endif
|
|
|
|
}{
|
|
|
|
# include <windows.h>
|
|
# ifndef __CYGWIN32__
|
|
# include <wtypes.h>
|
|
typedef _int8 Tsint8;
|
|
typedef unsigned _int8 Tuint8;
|
|
typedef _int16 Tsint16;
|
|
typedef unsigned _int16 Tuint16;
|
|
typedef _int32 Tsint32;
|
|
typedef unsigned _int32 Tuint32;
|
|
typedef _int64 Tsint64;
|
|
typedef unsigned _int64 Tuint64;
|
|
# endif
|
|
|
|
}
|
|
|
|
#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);
|
|
|
|
/*****************************************************************************/
|
|
/* Defining EnumProcessModules for openning `self' as an ffi-lib */
|
|
|
|
/* We'd like to use EnumProcessModules to find all loaded DLLs, but it's
|
|
only available in NT 4.0 and later. The alternative, Module32{First,Next},
|
|
is available *except* for NT 4.0! So we try EnumProcessModules first. */
|
|
|
|
@@IFDEF{WINDOWS_DYNAMIC_LOAD}{
|
|
#ifdef MZ_PRECISE_GC
|
|
START_XFORM_SKIP;
|
|
#endif
|
|
|
|
int epm_tried = 0;
|
|
typedef BOOL (WINAPI *EnumProcessModules_t)(HANDLE hProcess,
|
|
HMODULE* lphModule,
|
|
DWORD cb,
|
|
LPDWORD lpcbNeeded);
|
|
EnumProcessModules_t _EnumProcessModules;
|
|
#include <tlhelp32.h>
|
|
|
|
BOOL mzEnumProcessModules(HANDLE hProcess, HMODULE* lphModule,
|
|
DWORD cb, LPDWORD lpcbNeeded)
|
|
{
|
|
if (!epm_tried) {
|
|
HMODULE hm;
|
|
hm = LoadLibrary("psapi.dll");
|
|
if (hm) {
|
|
_EnumProcessModules =
|
|
(EnumProcessModules_t)GetProcAddress(hm, "EnumProcessModules");
|
|
}
|
|
epm_tried = 1;
|
|
}
|
|
|
|
if (_EnumProcessModules)
|
|
return _EnumProcessModules(hProcess, lphModule, cb, lpcbNeeded);
|
|
else {
|
|
HANDLE snapshot;
|
|
MODULEENTRY32 mod;
|
|
int i, ok;
|
|
|
|
snapshot = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE,
|
|
GetCurrentProcessId());
|
|
if (snapshot == INVALID_HANDLE_VALUE)
|
|
return FALSE;
|
|
|
|
for (i = 0; 1; i++) {
|
|
mod.dwSize = sizeof(mod);
|
|
if (!i)
|
|
ok = Module32First(snapshot, &mod);
|
|
else
|
|
ok = Module32Next(snapshot, &mod);
|
|
if (!ok)
|
|
break;
|
|
if (cb >= sizeof(HMODULE)) {
|
|
lphModule[i] = mod.hModule;
|
|
cb -= sizeof(HMODULE);
|
|
}
|
|
}
|
|
|
|
CloseHandle(snapshot);
|
|
*lpcbNeeded = i * sizeof(HMODULE);
|
|
return GetLastError() == ERROR_NO_MORE_FILES;
|
|
}
|
|
}
|
|
|
|
#ifdef MZ_PRECISE_GC
|
|
END_XFORM_SKIP;
|
|
#endif
|
|
}
|
|
|
|
/*****************************************************************************/
|
|
/* Library objects */
|
|
|
|
@cdefstruct[ffi-lib
|
|
[handle "void*"]
|
|
[name "Scheme_Object*"]
|
|
[objects "Scheme_Hash_Table*"]]
|
|
|
|
THREAD_LOCAL_DECL(static Scheme_Hash_Table *opened_libs);
|
|
|
|
/* (ffi-lib filename no-error?) -> ffi-lib */
|
|
@cdefine[ffi-lib 1 2]{
|
|
char *name;
|
|
Scheme_Object *path, *hashname;
|
|
void *handle;
|
|
int null_ok = 0;
|
|
ffi_lib_struct *lib;
|
|
if (!(SCHEME_PATH_STRINGP(argv[0]) || SCHEME_FALSEP(argv[0])))
|
|
scheme_wrong_type(MYNAME, "string-or-false", 0, argc, argv);
|
|
/* leave the filename as given, the system will look for it */
|
|
/* (`#f' means open the executable) */
|
|
path = SCHEME_FALSEP(argv[0]) ? NULL : TO_PATH(argv[0]);
|
|
name = (path==NULL) ? NULL : SCHEME_PATH_VAL(path);
|
|
hashname = (Scheme_Object*)((name==NULL) ? "" : name);
|
|
lib = (ffi_lib_struct*)scheme_hash_get(opened_libs, hashname);
|
|
if (!lib) {
|
|
Scheme_Hash_Table *ht;
|
|
@@@IFDEF{WINDOWS_DYNAMIC_LOAD}{
|
|
if (name==NULL) {
|
|
/* openning the executable is marked by a NULL handle */
|
|
handle = NULL;
|
|
null_ok = 1;
|
|
} else
|
|
handle = LoadLibrary(name);
|
|
}{
|
|
handle = dlopen(name, RTLD_NOW | RTLD_GLOBAL);
|
|
}
|
|
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);
|
|
}{
|
|
scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
|
|
MYNAME": couldn't open %V (%s)", argv[0], dlerror());
|
|
}
|
|
}
|
|
}
|
|
ht = scheme_make_hash_table(SCHEME_hash_string);
|
|
@cmake["lib" ffi-lib "handle" "argv[0]" "ht"]
|
|
scheme_hash_set(opened_libs, hashname, (Scheme_Object*)lib);
|
|
/* no dlclose finalizer - since the hash table always keeps a reference */
|
|
/* maybe add some explicit unload at some point */
|
|
}
|
|
return (Scheme_Object*)lib;
|
|
}
|
|
|
|
/* (ffi-lib-name ffi-lib) -> string */
|
|
@cdefine[ffi-lib-name 1]{
|
|
if (!SCHEME_FFILIBP(argv[0]))
|
|
scheme_wrong_type(MYNAME, "ffi-lib", 0, argc, argv);
|
|
return ((ffi_lib_struct*)argv[0])->name;
|
|
}
|
|
|
|
/*****************************************************************************/
|
|
/* Pull pointers (mostly functions) out of ffi-lib objects */
|
|
|
|
@cdefstruct[ffi-obj
|
|
[obj "void*"]
|
|
[name "char*"]
|
|
[lib "ffi_lib_struct*"]]
|
|
|
|
/* (ffi-obj objname ffi-lib-or-libname) -> ffi-obj */
|
|
@cdefine[ffi-obj 2]{
|
|
ffi_obj_struct *obj;
|
|
void *dlobj;
|
|
ffi_lib_struct *lib = NULL;
|
|
char *dlname;
|
|
if (SCHEME_FFILIBP(argv[1]))
|
|
lib = (ffi_lib_struct*)argv[1];
|
|
else if (SCHEME_PATH_STRINGP(argv[1]) || SCHEME_FALSEP(argv[1]))
|
|
lib = (ffi_lib_struct*)(foreign_ffi_lib(1,&argv[1]));
|
|
else
|
|
scheme_wrong_type(MYNAME, "ffi-lib", 1, argc, argv);
|
|
if (!SCHEME_BYTE_STRINGP(argv[0]))
|
|
scheme_wrong_type(MYNAME, "bytes", 0, argc, argv);
|
|
dlname = SCHEME_BYTE_STR_VAL(argv[0]);
|
|
obj = (ffi_obj_struct*)scheme_hash_get(lib->objects, (Scheme_Object*)dlname);
|
|
if (!obj) {
|
|
@@@IFDEF{WINDOWS_DYNAMIC_LOAD}{
|
|
if (lib->handle) {
|
|
dlobj = GetProcAddress(lib->handle, dlname);
|
|
} else {
|
|
/* this is for the executable-open case, which was marked by a NULL
|
|
* handle, deal with it by searching all current modules */
|
|
@DEFINE{NUM_QUICK_MODS 16}
|
|
HMODULE *mods, me, quick_mods[NUM_QUICK_MODS];
|
|
DWORD cnt = NUM_QUICK_MODS * sizeof(HMODULE), actual_cnt, i;
|
|
me = GetCurrentProcess();
|
|
mods = quick_mods;
|
|
if (mzEnumProcessModules(me, mods, cnt, &actual_cnt)) {
|
|
if (actual_cnt > cnt) {
|
|
cnt = actual_cnt;
|
|
mods = (HMODULE *)scheme_malloc_atomic(cnt);
|
|
if (!mzEnumProcessModules(me, mods, cnt, &actual_cnt))
|
|
mods = NULL;
|
|
} else
|
|
cnt = actual_cnt;
|
|
} else
|
|
mods = NULL;
|
|
if (mods) {
|
|
cnt /= sizeof(HMODULE);
|
|
for (i = 0; i < cnt; i++) {
|
|
dlobj = GetProcAddress(mods[i], dlname);
|
|
if (dlobj) break;
|
|
}
|
|
} else
|
|
dlobj = NULL;
|
|
}
|
|
if (!dlobj) {
|
|
long err;
|
|
err = GetLastError();
|
|
scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
|
|
MYNAME": couldn't get \"%s\" from %V (%E)",
|
|
dlname, lib->name, err);
|
|
}
|
|
}{
|
|
dlobj = dlsym(lib->handle, dlname);
|
|
if (!dlobj) {
|
|
const char *err;
|
|
err = dlerror();
|
|
if (err != NULL)
|
|
scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
|
|
MYNAME": couldn't get \"%s\" from %V (%s)",
|
|
dlname, lib->name, err);
|
|
}
|
|
}
|
|
@cmake["obj" ffi-obj "dlobj" "dlname" "lib"]
|
|
scheme_hash_set(lib->objects, (Scheme_Object*)dlname, (Scheme_Object*)obj);
|
|
}
|
|
return (obj == NULL) ? scheme_false : (Scheme_Object*)obj;
|
|
}
|
|
|
|
/* (ffi-obj-lib ffi-obj) -> ffi-lib */
|
|
@cdefine[ffi-obj-lib 1]{
|
|
if (!SCHEME_FFIOBJP(argv[0]))
|
|
scheme_wrong_type(MYNAME, "ffi-obj", 0, argc, argv);
|
|
return (Scheme_Object*)(((ffi_obj_struct*)argv[0])->lib);
|
|
}
|
|
|
|
/* (ffi-obj-name ffi-obj) -> string */
|
|
@cdefine[ffi-obj-name 1]{
|
|
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);
|
|
}
|
|
|
|
/*****************************************************************************/
|
|
/* 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 *)((((unsigned long)i) << 1) | 0x1))
|
|
|
|
@@@IFNDEF{SIXTY_FOUR_BIT_INTEGERS}{
|
|
|
|
/* longs and ints are really the same */
|
|
#define scheme_get_realint_val(x,y) \
|
|
scheme_get_int_val(x,(long*)(y))
|
|
#define scheme_get_unsigned_realint_val(x,y) \
|
|
scheme_get_unsigned_int_val(x,(unsigned long*)(y))
|
|
#define scheme_make_realinteger_value \
|
|
scheme_make_integer_value
|
|
#define scheme_make_realinteger_value_from_unsigned \
|
|
scheme_make_integer_value_from_unsigned
|
|
|
|
}{
|
|
|
|
/* 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. */
|
|
inline int scheme_get_realint_val(Scheme_Object *o, int *v)
|
|
{
|
|
if (SCHEME_INTP(o)) {
|
|
unsigned long lv = SCHEME_INT_VAL(o);
|
|
int i = (int)lv;
|
|
if (i != lv)
|
|
return 0;
|
|
*v = i;
|
|
return 1;
|
|
} else return 0;
|
|
}
|
|
inline int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v)
|
|
{
|
|
if (SCHEME_INTP(o)) {
|
|
unsigned long lv = SCHEME_INT_VAL(o);
|
|
unsigned int i = (unsigned int)lv;
|
|
if (i != lv)
|
|
return 0;
|
|
*v = i;
|
|
return 1;
|
|
} else return 0;
|
|
}
|
|
#define scheme_make_realinteger_value(ri) \
|
|
scheme_make_integer((long)(ri))
|
|
#define scheme_make_realinteger_value_from_unsigned(ri) \
|
|
scheme_make_integer((unsigned long)(ri))
|
|
|
|
}
|
|
|
|
/* This is related to the section of scheme.h that defines mzlonglong. */
|
|
#ifndef INT64_AS_LONG_LONG
|
|
#ifdef NO_LONG_LONG_TYPE
|
|
#ifndef SIXTY_FOUR_BIT_INTEGERS
|
|
#error foreign requires a 64-bit integer type type.
|
|
#endif
|
|
#endif
|
|
#endif
|
|
|
|
#define SCHEME_FALSEP_OR_CHAR_STRINGP(o) (SCHEME_FALSEP(o) || SCHEME_CHAR_STRINGP(o))
|
|
|
|
static mzchar *ucs4_string_or_null_to_ucs4_pointer(Scheme_Object *ucs)
|
|
{
|
|
if (SCHEME_FALSEP(ucs)) return NULL;
|
|
return SCHEME_CHAR_STR_VAL(ucs);
|
|
}
|
|
|
|
static unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs)
|
|
{
|
|
long ulen;
|
|
unsigned short *res;
|
|
res = scheme_ucs4_to_utf16
|
|
(SCHEME_CHAR_STR_VAL(ucs), 0, 1+SCHEME_CHAR_STRLEN_VAL(ucs),
|
|
NULL, -1, &ulen, 0);
|
|
return res;
|
|
}
|
|
|
|
static unsigned short *ucs4_string_or_null_to_utf16_pointer(Scheme_Object *ucs)
|
|
{
|
|
if (SCHEME_FALSEP(ucs)) return NULL;
|
|
return ucs4_string_to_utf16_pointer(ucs);
|
|
}
|
|
|
|
Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|
{
|
|
long ulen;
|
|
mzchar *res;
|
|
int end;
|
|
if (!utf) return scheme_false;
|
|
for (end=0; utf[end] != 0; end++) { /**/ }
|
|
res = scheme_utf16_to_ucs4(utf, 0, end, NULL, -1, &ulen, 0);
|
|
return scheme_make_sized_char_string(res, ulen, 0);
|
|
}
|
|
|
|
/*****************************************************************************/
|
|
/* Types */
|
|
|
|
@(begin
|
|
;; Types are defined with the `defctype' function. This looks like:
|
|
;; (defctype 'type-name
|
|
;; 'prop1 val1
|
|
;; 'prop2 val2
|
|
;; ...)
|
|
;; The current properties are:
|
|
;; stype: scheme binding for this type
|
|
;; cname: like stype but used for C identifiers
|
|
;; ftype: type name used by libffi (as ffi_type_X) (defaults to cname)
|
|
;; ctype: C type, or #f if none (defaults to ftype, with proper massaging)
|
|
;; macro: if specified as "X", use "SCHEME_XP" and "SCHEME_X_VAL" as the
|
|
;; defaults for the next two properties
|
|
;; pred: name of predicate macro
|
|
;; (or a function of the value and an ForeignAny obj pointer name, which
|
|
;; produces an expression that tests the value and sets the ForeignAny obj
|
|
;; accordingly.)
|
|
;; s->c: name of value extraction macro
|
|
;; (or #f which means that the predicate already sets the value, or a
|
|
;; function with the same arguments as above)
|
|
;; c->s: name of value construction macro/function
|
|
;; (or a function of the value that generates the expression)
|
|
;; offset: if specified as "X", use "SCHEME_X_OFFSET" to extract an offset
|
|
;; value for s->c, otherwise leave 0 as the offset
|
|
|
|
(define types null)
|
|
|
|
(require (for-syntax scheme/base))
|
|
|
|
(define (get-prop type prop)
|
|
(cadr (assq prop (cdr (assq type types)))))
|
|
|
|
(define type-counter
|
|
(let ([c 0])
|
|
(lambda ([flag #f])
|
|
(case flag
|
|
[(#f) (set! c (add1 c)) c]
|
|
[(last) (begin0 (add1 c) (set! c #f))]
|
|
[else (error "internal error")]))))
|
|
|
|
(define (describe-type stype cname ftype ctype pred s->c c->s offset)
|
|
@list{
|
|
#define FOREIGN_@cname (@(type-counter))
|
|
/* Type Name: @|stype|@(and (not (equal? cname stype)) @list{ (@cname)})
|
|
* LibFfi type: ffi_type_@ftype
|
|
* C type: @(or ctype "-none-")
|
|
* Predicate: @(cond [(not pred) "-none-"]
|
|
[(procedure? pred) (pred "<Scheme>" "aux")]
|
|
[else @list{@|pred|(<Scheme>)}])
|
|
* Scheme->C: @(cond [(not s->c)
|
|
(if pred "-none- (set by the predicate)" "-none-")]
|
|
[(procedure? s->c) (s->c "<Scheme>" "aux")]
|
|
[else @list{@|s->c|(<Scheme>)}])
|
|
* S->C offset: @(or offset 0)
|
|
* C->Scheme: @(cond [(not c->s) "-none-"]
|
|
[(procedure? c->s) (c->s "<C>")]
|
|
[else @list{@|c->s|(<C>)}])
|
|
*/})
|
|
|
|
(define (make-ctype type args)
|
|
(define (prop p . default)
|
|
(let loop ([args args])
|
|
(cond [(null? args) (and (pair? default) (car default))]
|
|
[(eq? p (car args))
|
|
(if (and (pair? (cadr args)) (eq? (caadr args) 'from))
|
|
(get-prop (cadadr args) p)
|
|
(cadr args))]
|
|
[else (loop (cddr args))])))
|
|
(let* ([stype (symbol->string type)]
|
|
[cname (scheme-id->c-name stype)]
|
|
[ftype (prop 'ftype cname)]
|
|
[ctype (prop 'ctype
|
|
(regexp-replace
|
|
#rx"^sint"
|
|
(regexp-replace #rx"^(u?int(?:[0-9]+))$" ftype "\\1_t")
|
|
"int"))]
|
|
[ftype (regexp-replace #rx"^(int|char|long)" ftype "s\\1")]
|
|
[macro (prop 'macro)]
|
|
[pred (prop 'pred (and macro @list{SCHEME_@|macro|P}))]
|
|
[s->c (prop 's->c (and macro @list{SCHEME_@|macro|_VAL}))]
|
|
[c->s (prop 'c->s)]
|
|
[offset (prop 'offset #f)])
|
|
(output (describe-type stype cname ftype ctype pred s->c c->s offset))
|
|
`(,type (stype ,stype) (cname ,cname) (ftype ,ftype) (ctype ,ctype)
|
|
(macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset))))
|
|
|
|
(define (defctype name . args)
|
|
(set! types (append types (list (make-ctype name args)))))
|
|
|
|
(define-syntax (map-types stx)
|
|
(syntax-case stx ()
|
|
[(_ body ...)
|
|
(let ()
|
|
(define (id sym) (datum->syntax stx sym stx))
|
|
(define-values (exprs semi?)
|
|
(syntax-case stx ()
|
|
[(_ #:semicolons? s? body ...) (values #'(body ...) #'s?)]
|
|
[(_ body ...) (values #'(body ...) #'#t)]))
|
|
(with-syntax ([(body ...) exprs]
|
|
[semi? semi?]
|
|
[stype (id 'stype)]
|
|
[cname (id 'cname)]
|
|
[ctype (id 'ctype)]
|
|
[ftype (id 'ftype)]
|
|
[macro (id 'macro)]
|
|
[pred (id 'pred)]
|
|
[s->c (id 's->c)]
|
|
[c->s (id 'c->s)]
|
|
[offset (id 'offset)]
|
|
[ptr? (id 'ptr?)])
|
|
#'(maplines #:semicolons? 'semi?
|
|
(lambda (t)
|
|
(define data (cdr t))
|
|
(define (get sym) (cadr (assq sym data)))
|
|
(let* ([stype (get 'stype)]
|
|
[cname (get 'cname)]
|
|
[ftype (get 'ftype)]
|
|
[ctype (get 'ctype)]
|
|
[macro (get 'macro)]
|
|
[pred (get 'pred)]
|
|
[s->c (get 's->c)]
|
|
[c->s (get 'c->s)]
|
|
[offset (get 'offset)]
|
|
[ptr? (or (equal? "pointer" ftype)
|
|
(equal? "gcpointer" ftype))])
|
|
body ...))
|
|
types)))]))
|
|
|
|
(define (defctype* name/+ftype ctype pred s->c c->s)
|
|
(let ([name (if (pair? name/+ftype) (car name/+ftype) name/+ftype)]
|
|
[ftype (and (pair? name/+ftype) (cadr name/+ftype))])
|
|
(apply defctype name
|
|
`(ctype ,ctype
|
|
,@(if ftype `(ftype ,ftype) `())
|
|
pred ,(if (string? pred) @list{SCHEME_@|pred|P} pred)
|
|
s->c ,(if (string? s->c) @list{SCHEME_@|s->c|_VAL} s->c)
|
|
c->s ,(if (string? c->s) @list{scheme_make_@|c->s|} c->s)))))
|
|
|
|
)
|
|
|
|
/***********************************************************************
|
|
* 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(long) == 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' to change.
|
|
**********************************************************************/
|
|
|
|
/* returns #<void> when used as output type, not for input types. */
|
|
@(defctype 'void
|
|
'ctype #f 'pred #f 's->c #f 'c->s (lambda (x) "scheme_void"))
|
|
|
|
@; libffi primitive types
|
|
@; scheme-name c-type SCHEME_?P SCHEME_?_VAL scheme_make_
|
|
@(defctype* 'int8 "Tsint8" "INT" "INT" "integer")
|
|
|
|
@(defctype* 'uint8 "Tuint8" "INT" "UINT" "integer_from_unsigned")
|
|
|
|
@(defctype* 'int16 "Tsint16" "INT" "INT" "integer")
|
|
|
|
@(defctype* 'uint16 "Tuint16" "INT" "UINT" "integer_from_unsigned")
|
|
|
|
/* Treats integers properly: */
|
|
@(defctype* 'int32 "Tsint32"
|
|
(lambda (x aux) @list{scheme_get_realint_val(@x,&@aux)}) #f
|
|
"realinteger_value")
|
|
|
|
/* Treats integers properly: */
|
|
@(defctype* 'uint32 "Tuint32"
|
|
(lambda (x aux) @list{scheme_get_unsigned_realint_val(@x,&@aux)}) #f
|
|
"realinteger_value_from_unsigned")
|
|
|
|
@; mzlonglong is always assumed to be 64 bits, or the above will throw an error
|
|
@(defctype* 'int64 "Tsint64"
|
|
(lambda (x aux) @list{scheme_get_long_long_val(@x,&@aux)}) #f
|
|
"integer_value_from_long_long")
|
|
|
|
@(defctype* 'uint64 "Tuint64"
|
|
(lambda (x aux) @list{scheme_get_unsigned_long_long_val(@x,&@aux)}) #f
|
|
"integer_value_from_unsigned_long_long")
|
|
|
|
/* This is like int32, but always assumes fixnum: */
|
|
@(defctype* '(fixint "int32") "Tsint32" "INT" "INT" "integer")
|
|
|
|
/* This is like uint32, but always assumes fixnum: */
|
|
@(defctype* '(ufixint "uint32") "Tuint32" "INT" "UINT" "integer_from_unsigned")
|
|
|
|
/* This is what mzscheme defines as long: */
|
|
@@@IFNDEF{SIXTY_FOUR_BIT_INTEGERS}{
|
|
#define ffi_type_smzlong ffi_type_sint32
|
|
#define ffi_type_umzlong ffi_type_uint32
|
|
}{
|
|
#define ffi_type_smzlong ffi_type_sint64
|
|
#define ffi_type_umzlong ffi_type_uint64
|
|
}
|
|
|
|
@;{ implemented in Scheme
|
|
/* This is what mzscheme defines as long: */
|
|
(defctype* '(long "smzlong") "long"
|
|
(lambda (x aux) list{scheme_get_int_val(@x,&@aux)}) #f
|
|
"integer_value")
|
|
@line{/* This is what mzscheme defines as ulong: */}
|
|
(defctype* '(ulong "umzlong") "unsigned long"
|
|
(lambda (x aux) @list{scheme_get_unsigned_int_val(@x,&@aux)}) #f
|
|
"integer_value_from_unsigned")
|
|
;}@;
|
|
@;
|
|
/* This is what mzscheme defines as long, assuming fixnums: */
|
|
@(defctype* '(fixnum "smzlong")
|
|
"long" "INT" "INT" "integer")
|
|
|
|
/* This is what mzscheme defines as ulong, assuming fixnums: */
|
|
@(defctype* '(ufixnum "umzlong")
|
|
"unsigned long" "INT" "UINT" "integer_from_unsigned")
|
|
|
|
@(defctype* 'float "float" "FLT" "FLT" "float")
|
|
|
|
@(defctype* 'double "double" "DBL" "DBL" "double")
|
|
@;
|
|
@; Not useful? not implemented in any case.
|
|
@; (defctype* 'longdouble "long double" ...???...)
|
|
|
|
/* A double that will coerce numbers to doubles: */
|
|
@(defctype* '(double* "double") "double"
|
|
;; use a list to avoid automatic "SCHEME_..._VAL" wrapping
|
|
"REAL" '("scheme_real_to_double") "double")
|
|
|
|
/* Booleans -- implemented as an int which is 1 or 0: */
|
|
@(defctype 'bool
|
|
'ftype "int"
|
|
'pred (lambda (x aux) "1")
|
|
's->c "SCHEME_TRUEP"
|
|
'c->s (lambda (x) @list{(@|x|?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. */
|
|
|
|
@(defctype 'string/ucs-4
|
|
'ftype "pointer"
|
|
'ctype "mzchar*"
|
|
'pred "SCHEME_FALSEP_OR_CHAR_STRINGP"
|
|
's->c "ucs4_string_or_null_to_ucs4_pointer"
|
|
'c->s "scheme_make_char_string_without_copying")
|
|
|
|
@(defctype 'string/utf-16
|
|
'ftype "pointer"
|
|
'ctype "unsigned short*"
|
|
'pred "SCHEME_FALSEP_OR_CHAR_STRINGP"
|
|
's->c "ucs4_string_or_null_to_utf16_pointer"
|
|
'c->s "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) */
|
|
|
|
@(defctype 'bytes
|
|
'ftype "pointer"
|
|
'ctype "char*"
|
|
'pred (lambda (x aux)
|
|
@list{SCHEME_FALSEP(@x)||SCHEME_BYTE_STRINGP(@x)})
|
|
's->c (lambda (x aux)
|
|
@list{SCHEME_FALSEP(@x)?NULL:SCHEME_BYTE_STR_VAL(@x)})
|
|
'c->s (lambda (x)
|
|
@list{(@|x|==NULL)?scheme_false:@;
|
|
scheme_make_byte_string_without_copying(@x)}))
|
|
|
|
@(defctype 'path
|
|
'ftype "pointer"
|
|
'ctype "char*"
|
|
'pred (lambda (x aux)
|
|
@list{SCHEME_FALSEP(@x)||SCHEME_PATH_STRINGP(@x)})
|
|
's->c (lambda (x aux)
|
|
@list{SCHEME_FALSEP(@x)?NULL:SCHEME_PATH_VAL(TO_PATH(@x))})
|
|
'c->s (lambda (x)
|
|
@list{(@|x|==NULL)?scheme_false:@;
|
|
scheme_make_path_without_copying(@x)}))
|
|
|
|
@(defctype 'symbol
|
|
'ftype "pointer"
|
|
'ctype "char*"
|
|
'pred "SCHEME_SYMBOLP"
|
|
's->c "SCHEME_SYM_VAL"
|
|
'c->s "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. */
|
|
@(defctype 'pointer
|
|
'ctype "void*"
|
|
'macro "FFIANYPTR"
|
|
'offset "FFIANYPTR"
|
|
'c->s "scheme_make_foreign_external_cpointer")
|
|
|
|
@(defctype 'gcpointer
|
|
'ftype "gcpointer"
|
|
'ctype "void*"
|
|
'macro "FFIANYPTR"
|
|
'offset "FFIANYPTR"
|
|
'c->s "scheme_make_foreign_cpointer")
|
|
|
|
@; This is probably not needed
|
|
@; /* Used for ffi-callback objects: */
|
|
@; @(defctype 'callback
|
|
@; 'ftype "pointer"
|
|
@; 'ctype "void*"
|
|
@; 'macro "FFICALLBACK"
|
|
@; 's->c (lambda (x aux) @list{((ffi_callback_struct*)(@x))->callback})
|
|
@; 'c->s (lambda (x) x))
|
|
@;
|
|
/* This is used for passing and Scheme_Object* value as is. Useful for
|
|
* functions that know about Scheme_Object*s, like Racket's. */
|
|
@(defctype 'scheme
|
|
'ftype "gcpointer"
|
|
'ctype "Scheme_Object*"
|
|
'pred (lambda (x aux) "1")
|
|
's->c (lambda (x aux) x)
|
|
'c->s (lambda (x) x))
|
|
|
|
/* Special type, not actually used for anything except to mark values
|
|
* that are treated like pointers but not referenced. Used for
|
|
* creating function types. */
|
|
@(defctype 'fpointer 'ftype "pointer" 'ctype "void*")
|
|
|
|
typedef union _ForeignAny {
|
|
@(map-types (when ctype @list{@ctype x_@cname}))
|
|
} ForeignAny;
|
|
|
|
/* This is a tag that is used to identify user-made struct types. */
|
|
@; last makes sure this is the last one value that gets used
|
|
#define FOREIGN_struct (@(type-counter 'last))
|
|
|
|
/*****************************************************************************/
|
|
/* 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.)
|
|
*/
|
|
@cdefstruct[ctype
|
|
[basetype "Scheme_Object*"]
|
|
[scheme_to_c "Scheme_Object*"]
|
|
[c_to_scheme "Scheme_Object*"]]
|
|
|
|
static ffi_type ffi_type_gcpointer;
|
|
|
|
#define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype)
|
|
#define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))
|
|
#define CTYPE_PRIMP(x) (!CTYPE_USERP(x))
|
|
#define CTYPE_PRIMTYPE(x) ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c))
|
|
#define CTYPE_PRIMLABEL(x) ((long)(((ctype_struct*)(x))->c_to_scheme))
|
|
#define CTYPE_USER_S2C(x) (((ctype_struct*)(x))->scheme_to_c)
|
|
#define CTYPE_USER_C2S(x) (((ctype_struct*)(x))->c_to_scheme)
|
|
|
|
/* Returns #f for primitive types. */
|
|
@cdefine[ctype-basetype 1]{
|
|
if (!SCHEME_CTYPEP(argv[0]))
|
|
scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
|
|
return CTYPE_BASETYPE(argv[0]);
|
|
}
|
|
|
|
@cdefine[ctype-scheme->c 1]{
|
|
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;
|
|
}
|
|
|
|
@cdefine[ctype-c->scheme 1]{
|
|
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;
|
|
}
|
|
|
|
/* 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)) {
|
|
@(map-types @list{case FOREIGN_@|cname|: @;
|
|
return @(if ctype @list{sizeof(@ctype)} "0")})
|
|
/* for structs */
|
|
default: return CTYPE_PRIMTYPE(type)->size;
|
|
}
|
|
}
|
|
|
|
/* (make-ctype basetype scheme->c c->scheme) -> ctype */
|
|
/* The scheme->c can throw type errors to check for valid arguments */
|
|
/* a #f means no conversion function, if both are #f -- then just return the */
|
|
/* basetype. */
|
|
@cdefine[make-ctype 3]{
|
|
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 {
|
|
@cmake["type" ctype "argv[0]" "argv[1]" "argv[2]"]
|
|
return (Scheme_Object*)type;
|
|
}
|
|
@hush
|
|
}
|
|
|
|
/* see below */
|
|
void free_libffi_type(void *ignored, void *p)
|
|
{
|
|
free(((ffi_type*)p)->elements);
|
|
free(p);
|
|
}
|
|
|
|
/*****************************************************************************/
|
|
/* ABI spec */
|
|
|
|
@defsymbols[default stdcall sysv]
|
|
|
|
ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
|
|
{
|
|
if (SCHEME_FALSEP(sym) || SAME_OBJ(sym, default_sym))
|
|
return FFI_DEFAULT_ABI;
|
|
else if (SAME_OBJ(sym, sysv_sym)) {
|
|
#ifdef WINDOWS_DYNAMIC_LOAD
|
|
return FFI_SYSV;
|
|
#else
|
|
scheme_signal_error("%s: ABI not implemented: %V", who, sym);
|
|
#endif
|
|
} else if (SAME_OBJ(sym, stdcall_sym)) {
|
|
#ifdef WINDOWS_DYNAMIC_LOAD
|
|
return FFI_STDCALL;
|
|
#else
|
|
scheme_signal_error("%s: ABI not implemented: %V", who, sym);
|
|
#endif
|
|
} else {
|
|
scheme_signal_error("%s: unknown ABI: %V", who, sym);
|
|
}
|
|
return 0; /* hush the compiler */
|
|
}
|
|
|
|
/* helper macro */
|
|
#define GET_ABI(name,n) \
|
|
((argc > (n)) ? sym_to_abi((name),argv[n]) : FFI_DEFAULT_ABI)
|
|
|
|
/*****************************************************************************/
|
|
/* cstruct types */
|
|
|
|
/* (make-cstruct-type types [abi]) -> ctype */
|
|
/* This creates a new primitive type that is a struct. This type can be used
|
|
* with cpointer objects, except that the contents is used rather than the
|
|
* pointer value. Marshaling to lists or whatever should be done in Scheme. */
|
|
@cdefine[make-cstruct-type 1 2]{
|
|
Scheme_Object *p, *base;
|
|
/* since ffi_type objects can be used in callbacks, they are allocated using
|
|
* malloc so they don't move, and they are freed when the Scheme object is
|
|
* GCed. */
|
|
GC_CAN_IGNORE ffi_type **elements, *libffi_type, **dummy;
|
|
ctype_struct *type;
|
|
ffi_cif cif;
|
|
int i, nargs;
|
|
ffi_abi abi;
|
|
nargs = scheme_proper_list_length(argv[0]);
|
|
if (nargs < 0) scheme_wrong_type(MYNAME, "proper list", 0, argc, argv);
|
|
abi = GET_ABI(MYNAME,1);
|
|
/* allocate the type elements */
|
|
elements = malloc((nargs+1) * sizeof(ffi_type*));
|
|
elements[nargs] = NULL;
|
|
for (i=0, p=argv[0]; i<nargs; i++, p=SCHEME_CDR(p)) {
|
|
if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
|
|
scheme_wrong_type(MYNAME, "list-of-C-types", 0, argc, argv);
|
|
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
|
|
scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 0, argc, argv);
|
|
elements[i] = CTYPE_PRIMTYPE(base);
|
|
}
|
|
/* allocate the new libffi type object */
|
|
libffi_type = malloc(sizeof(ffi_type));
|
|
libffi_type->size = 0;
|
|
libffi_type->alignment = 0;
|
|
libffi_type->type = FFI_TYPE_STRUCT;
|
|
libffi_type->elements = elements;
|
|
/* use ffi_prep_cif to set the size and alignment information */
|
|
dummy = &libffi_type;
|
|
if (ffi_prep_cif(&cif, abi, 1, &ffi_type_void, dummy) != FFI_OK)
|
|
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
|
|
@cmake["type" ctype "argv[0]"
|
|
"(Scheme_Object*)libffi_type"
|
|
"(Scheme_Object*)FOREIGN_struct"]
|
|
scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
|
|
return (Scheme_Object*)type;
|
|
}
|
|
|
|
/*****************************************************************************/
|
|
/* Callback type */
|
|
|
|
@cdefstruct[ffi-callback
|
|
[callback "void*"]
|
|
[proc "Scheme_Object*"]
|
|
[itypes "Scheme_Object*"]
|
|
[otype "Scheme_Object*"]
|
|
[call_in_scheduler "char"]]
|
|
|
|
/*****************************************************************************/
|
|
/* Pointer objects */
|
|
/* use cpointer (with a NULL tag when creating), #f for NULL */
|
|
|
|
#define SCHEME_FFIANYPTRP(x) \
|
|
(SCHEME_FALSEP(x) || SCHEME_CPTRP(x) || SCHEME_FFIOBJP(x) || \
|
|
SCHEME_BYTE_STRINGP(x) || SCHEME_FFICALLBACKP(x))
|
|
#define SCHEME_FFIANYPTR_VAL(x) \
|
|
(SCHEME_CPTRP(x) ? SCHEME_CPTR_VAL(x) : \
|
|
(SCHEME_FALSEP(x) ? NULL : \
|
|
(SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \
|
|
(SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \
|
|
(SCHEME_FFICALLBACKP(x) ? ((ffi_callback_struct *)x)->callback : \
|
|
NULL)))))
|
|
#define SCHEME_FFIANYPTR_OFFSET(x) \
|
|
(SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0)
|
|
#define SCHEME_FFIANYPTR_OFFSETVAL(x) \
|
|
W_OFFSET(SCHEME_FFIANYPTR_VAL(x), SCHEME_FFIANYPTR_OFFSET(x))
|
|
|
|
#define SCHEME_CPOINTER_W_OFFSET_P(x) \
|
|
SAME_TYPE(SCHEME_TYPE(x), scheme_offset_cpointer_type)
|
|
|
|
#define scheme_make_foreign_cpointer(x) \
|
|
((x==NULL)?scheme_false:scheme_make_cptr(x,NULL))
|
|
|
|
#define scheme_make_foreign_external_cpointer(x) \
|
|
((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL))
|
|
|
|
@cdefine[cpointer? 1]{
|
|
return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false;
|
|
}
|
|
|
|
@cdefine[cpointer-tag 1]{
|
|
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;
|
|
}
|
|
|
|
@cdefine[set-cpointer-tag! 2]{
|
|
if (!SCHEME_CPTRP(argv[0]))
|
|
scheme_wrong_type(MYNAME, "proper-cpointer", 0, argc, argv);
|
|
SCHEME_CPTR_TYPE(argv[0]) = argv[1];
|
|
return scheme_void;
|
|
}
|
|
|
|
/*****************************************************************************/
|
|
/* Scheme<-->C conversions */
|
|
|
|
/* On big endian machines we need to know whether we're pulling a value from an
|
|
* argument location where it always takes a whole word or straight from a
|
|
* memory location -- deal with it via a C2SCHEME macro wrapper that is used
|
|
* for both the function definition and calls */
|
|
#ifdef SCHEME_BIG_ENDIAN
|
|
#define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta,argsloc)
|
|
#define REF_CTYPE(ctype) (((sizeof(ctype)<sizeof(int)) && args_loc) \
|
|
? ((ctype)(((int*)W_OFFSET(src,delta))[0])) \
|
|
: (((ctype *)W_OFFSET(src,delta))[0]))
|
|
#else
|
|
#define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta)
|
|
#define REF_CTYPE(ctype) (((ctype *)W_OFFSET(src,delta))[0])
|
|
#endif
|
|
|
|
static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
|
|
int delta, int args_loc)
|
|
{
|
|
Scheme_Object *res;
|
|
if (!SCHEME_CTYPEP(type))
|
|
scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
|
|
if (CTYPE_USERP(type)) {
|
|
res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc);
|
|
if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
|
|
return res;
|
|
else
|
|
return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res));
|
|
} else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
|
|
return scheme_make_foreign_external_cpointer(*(void **)W_OFFSET(src, delta));
|
|
} else switch (CTYPE_PRIMLABEL(type)) {
|
|
@(map-types
|
|
@list{case FOREIGN_@|cname|: return @;
|
|
@(if ctype
|
|
(let ([x (list "REF_CTYPE("ctype")")])
|
|
(if (procedure? c->s) (c->s x) (list c->s"("x")")))
|
|
"scheme_void")})
|
|
case FOREIGN_struct:
|
|
return scheme_make_foreign_cpointer(W_OFFSET(src, delta));
|
|
default: scheme_signal_error("corrupt foreign type: %V", type);
|
|
}
|
|
@hush
|
|
}
|
|
#undef REF_CTYPE
|
|
|
|
/* On big endian machines we need to know whether we're pulling a value from an
|
|
* argument location where it always takes a whole word or straight from a
|
|
* memory location -- deal with it as above, via a SCHEME2C macro wrapper that
|
|
* is used for both the function definition and calls, but the actual code in
|
|
* the function is different: in the relevant cases zero an int and offset the
|
|
* ptr */
|
|
|
|
/* Usually writes the C object to dst and returns NULL. When basetype_p is not
|
|
* NULL, then any pointer value (any pointer or a struct) is returned, and the
|
|
* basetype_p is set to the corrsponding number tag. If basetype_p is NULL,
|
|
* then a struct value will be *copied* into dst. */
|
|
static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|
Scheme_Object *val, long *basetype_p, long *_offset,
|
|
int ret_loc)
|
|
{
|
|
if (!SCHEME_CTYPEP(type))
|
|
scheme_wrong_type("Scheme->C", "C-type", 0, 1, &type);
|
|
while (CTYPE_USERP(type)) {
|
|
if (!SCHEME_FALSEP(CTYPE_USER_S2C(type)))
|
|
val = _scheme_apply(CTYPE_USER_S2C(type), 1, (Scheme_Object**)(&val));
|
|
type = CTYPE_BASETYPE(type);
|
|
}
|
|
if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
|
|
/* No need for the SET_CTYPE trick for pointers. */
|
|
if (SCHEME_FFICALLBACKP(val))
|
|
((void**)W_OFFSET(dst,delta))[0] = ((ffi_callback_struct*)val)->callback;
|
|
else if (SCHEME_CPTRP(val))
|
|
((void**)W_OFFSET(dst,delta))[0] = SCHEME_CPTR_VAL(val);
|
|
else if (SCHEME_FFIOBJP(val))
|
|
((void**)W_OFFSET(dst,delta))[0] = ((ffi_obj_struct*)val)->obj;
|
|
else if (SCHEME_FALSEP(val))
|
|
((void**)W_OFFSET(dst,delta))[0] = NULL;
|
|
else /* ((void**)W_OFFSET(dst,delta))[0] = val; */
|
|
scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val);
|
|
} else switch (CTYPE_PRIMLABEL(type)) {
|
|
@(map-types #:semicolons? #f
|
|
(define (wrong-type obj type)
|
|
@list{scheme_wrong_type("Scheme->C","@type",0,1,&(@obj))})
|
|
@list{
|
|
case FOREIGN_@|cname|:
|
|
@(let* ([x (and ctype @list{(((@|ctype|*)W_OFFSET(dst,delta))[0])})]
|
|
[f (lambda (p)
|
|
(if (procedure? p) @p["val" x] @list{@|p|(val)}))])
|
|
(cond
|
|
[(not x)
|
|
@list{if (!ret_loc) @wrong-type["type" "non-void-C-type"];
|
|
break;
|
|
}]
|
|
[(not s->c)
|
|
@list{if (!(@(if ptr? "ret_loc" (pred "val" x)))) @;
|
|
@wrong-type["val" stype];
|
|
@(if ptr? "break" "return NULL");}]
|
|
[else
|
|
@list{
|
|
@@IFDEF{SCHEME_BIG_ENDIAN}{
|
|
if (sizeof(@ctype)<sizeof(int) && ret_loc) {
|
|
((int*)W_OFFSET(dst,delta))[0] = 0;
|
|
delta += (sizeof(int)-sizeof(@ctype));
|
|
}}
|
|
if (@f[pred]) {
|
|
@ctype tmp@";"@and[offset]{ long toff@";"}
|
|
tmp = (@ctype)(@f[s->c]);
|
|
@and[offset @list{
|
|
toff = SCHEME_@|offset|_OFFSET(val);
|
|
if (_offset) *_offset = toff;@;
|
|
@"\n" }]@;
|
|
@(if ptr?
|
|
@list{if (basetype_p == NULL || @;
|
|
@(if offset
|
|
@list{(tmp == NULL && toff == 0)}
|
|
@list{tmp == NULL})) {
|
|
@x = @(if offset
|
|
@list{(_offset ? tmp : @;
|
|
(@ctype)W_OFFSET(tmp, toff))}
|
|
"tmp");
|
|
return NULL;
|
|
} else {
|
|
*basetype_p = FOREIGN_@cname;
|
|
return @(if offset
|
|
@list{_offset ? tmp : @;
|
|
(@ctype)W_OFFSET(tmp, toff)}
|
|
"tmp");
|
|
}}
|
|
@list{@x = tmp@";" return NULL@";"})
|
|
} else {
|
|
@wrong-type["val" stype];
|
|
@hush
|
|
}}]))})
|
|
case FOREIGN_struct:
|
|
if (!SCHEME_FFIANYPTRP(val))
|
|
scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);
|
|
{
|
|
void* p = SCHEME_FFIANYPTR_VAL(val);
|
|
long poff = SCHEME_FFIANYPTR_OFFSET(val);
|
|
if (basetype_p == NULL) {
|
|
if (p == NULL && poff == 0)
|
|
scheme_signal_error("FFI pointer value was NULL");
|
|
memcpy(W_OFFSET(dst, delta), W_OFFSET(p, poff),
|
|
CTYPE_PRIMTYPE(type)->size);
|
|
return NULL;
|
|
} else {
|
|
*basetype_p = FOREIGN_struct;
|
|
if (_offset) {
|
|
*_offset = poff;
|
|
return p;
|
|
} else {
|
|
return W_OFFSET(p, poff);
|
|
}
|
|
}
|
|
}
|
|
default: scheme_signal_error("corrupt foreign type: %V", type);
|
|
}
|
|
return NULL; /* hush the compiler */
|
|
}
|
|
#undef SET_CTYPE
|
|
|
|
/*****************************************************************************/
|
|
/* C type information */
|
|
|
|
/* (ctype-sizeof type) -> int, returns 0 for void, error if not a C type */
|
|
@cdefine[ctype-sizeof 1]{
|
|
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 */
|
|
}
|
|
|
|
/* (ctype-alignof type) -> int, returns 0 for void, error if not a C type */
|
|
@cdefine[ctype-alignof 1]{
|
|
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 */
|
|
}
|
|
|
|
/* (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.) */
|
|
@cdefine[compiler-sizeof 1]{
|
|
int res=0;
|
|
int basetype = 0; /* 1=int, 2=char, 3=void, 4=float, 5=double */
|
|
int intsize = 0; /* "short" => decrement, "long" => increment */
|
|
int stars = 0; /* number of "*"s */
|
|
Scheme_Object *l = argv[0], *p;
|
|
while (!SAME_OBJ(l, scheme_null)) {
|
|
if (SCHEME_PAIRP(l)) { p = SCHEME_CAR(l); l = SCHEME_CDR(l); }
|
|
else { p = l; l = scheme_null; }
|
|
if (!SCHEME_SYMBOLP(p)) {
|
|
scheme_wrong_type(MYNAME, "list of symbols", 0, argc, argv);
|
|
} else if (!strcmp(SCHEME_SYM_VAL(p),"int")) {
|
|
if (basetype==0) basetype=1;
|
|
else scheme_signal_error(MYNAME": extraneous type: %V", p);
|
|
} else if (!strcmp(SCHEME_SYM_VAL(p),"char")) {
|
|
if (basetype==0) basetype=2;
|
|
else scheme_signal_error(MYNAME": extraneous type: %V", p);
|
|
} else if (!strcmp(SCHEME_SYM_VAL(p),"void")) {
|
|
if (basetype==0) basetype=3;
|
|
else scheme_signal_error(MYNAME": extraneous type: %V", p);
|
|
} else if (!strcmp(SCHEME_SYM_VAL(p),"float")) {
|
|
if (basetype==0) basetype=4;
|
|
else scheme_signal_error(MYNAME": extraneous type: %V", p);
|
|
} else if (!strcmp(SCHEME_SYM_VAL(p),"double")) {
|
|
if (basetype==0 || basetype==4) basetype=5;
|
|
else scheme_signal_error(MYNAME": extraneous type: %V", p);
|
|
} else if (!strcmp(SCHEME_SYM_VAL(p),"short")) {
|
|
if (intsize>0)
|
|
scheme_signal_error(MYNAME": cannot use both 'short and 'long");
|
|
else intsize--;
|
|
} else if (!strcmp(SCHEME_SYM_VAL(p),"long")) {
|
|
if (intsize<0)
|
|
scheme_signal_error(MYNAME": cannot use both 'short and 'long");
|
|
else intsize++;
|
|
} else if (!strcmp(SCHEME_SYM_VAL(p),"*")) {
|
|
stars++;
|
|
} else {
|
|
scheme_wrong_type(MYNAME, "list of C type symbols", 0, argc, argv);
|
|
}
|
|
}
|
|
if (stars > 1)
|
|
scheme_signal_error(MYNAME": cannot handle more than one '*");
|
|
if (intsize < -1)
|
|
scheme_signal_error(MYNAME": cannot handle more than one 'short");
|
|
if (intsize > 2)
|
|
scheme_signal_error(MYNAME": cannot handle more than two 'long");
|
|
if (basetype == 0) basetype = 1; /* int is the default type */
|
|
/* don't assume anything, so it can be used to verify compiler assumptions */
|
|
/* (only forbid stuff that the compiler doesn't allow) */
|
|
@@DEFINE{RETSIZE(t) res=((stars==0)?sizeof(t):sizeof(t *))}
|
|
switch (basetype) {
|
|
case 1: /* int */
|
|
switch (intsize) {
|
|
case 0: RETSIZE(int); break;
|
|
case 1: RETSIZE(long int); break;
|
|
@@@IFDEF{INT64_AS_LONG_LONG}{
|
|
case 2: RETSIZE(_int64); break; /* MSVC doesn't allow long long */
|
|
}{
|
|
case 2: RETSIZE(long long int); break;
|
|
}
|
|
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);
|
|
}
|
|
|
|
/*****************************************************************************/
|
|
/* Pointer type user functions */
|
|
|
|
@defsymbols[nonatomic atomic stubborn uncollectable eternal
|
|
interior atomic-interior raw fail-ok]
|
|
|
|
/* (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. */
|
|
@cdefine[malloc 1 5]{
|
|
int i, size=0, num=0, failok=0;
|
|
void *from = NULL, *res = NULL;
|
|
long foff = 0;
|
|
Scheme_Object *mode = NULL, *a, *base = NULL;
|
|
void *(*mf)(size_t);
|
|
for (i=0; i<argc; i++) {
|
|
a = argv[i];
|
|
if (SCHEME_INTP(a)) {
|
|
if (num != 0)
|
|
scheme_signal_error(MYNAME": specifying a second integer size: %V", a);
|
|
num = SCHEME_INT_VAL(a);
|
|
if (num <= 0)
|
|
scheme_wrong_type(MYNAME, "positive-integer", 0, argc, argv);
|
|
} else if (SCHEME_CTYPEP(a)) {
|
|
if (size != 0)
|
|
scheme_signal_error(MYNAME": specifying a second type: %V", a);
|
|
if (NULL == (base = get_ctype_base(a)))
|
|
scheme_wrong_type(MYNAME, "C-type", i, argc, argv);
|
|
size = ctype_sizeof(a);
|
|
if (size <= 0)
|
|
scheme_wrong_type(MYNAME, "non-void-C-type", i, argc, argv);
|
|
} else if (SAME_OBJ(a, fail_ok_sym)) {
|
|
failok = 1;
|
|
} else if (SCHEME_SYMBOLP(a)) {
|
|
if (mode != NULL)
|
|
scheme_signal_error(MYNAME": specifying a second mode symbol: %V", a);
|
|
mode = a;
|
|
} else if (SCHEME_FFIANYPTRP(a) && !SCHEME_FALSEP(a)) {
|
|
if (from != NULL)
|
|
scheme_signal_error(MYNAME": specifying a second source pointer: %V",
|
|
a);
|
|
from = SCHEME_FFIANYPTR_VAL(a);
|
|
foff = SCHEME_FFIANYPTR_OFFSET(a);
|
|
} else {
|
|
scheme_wrong_type(MYNAME, "malloc-argument", i, argc, argv);
|
|
}
|
|
}
|
|
if ((num == 0) && (size == 0)) scheme_signal_error(MYNAME": no size given");
|
|
size = ((size==0) ? 1 : size) * ((num==0) ? 1 : num);
|
|
if (mode == NULL)
|
|
mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_gcpointer)
|
|
? scheme_malloc : scheme_malloc_atomic;
|
|
else if (SAME_OBJ(mode, nonatomic_sym)) mf = scheme_malloc;
|
|
else if (SAME_OBJ(mode, atomic_sym)) mf = scheme_malloc_atomic;
|
|
else if (SAME_OBJ(mode, stubborn_sym)) mf = scheme_malloc_stubborn;
|
|
else if (SAME_OBJ(mode, eternal_sym)) mf = scheme_malloc_eternal;
|
|
else if (SAME_OBJ(mode, uncollectable_sym)) mf = scheme_malloc_uncollectable;
|
|
else if (SAME_OBJ(mode, interior_sym)) mf = scheme_malloc_atomic_allow_interior;
|
|
else if (SAME_OBJ(mode, atomic_interior_sym)) mf = scheme_malloc_atomic_allow_interior;
|
|
else if (SAME_OBJ(mode, raw_sym)) mf = malloc;
|
|
else {
|
|
scheme_signal_error(MYNAME": bad allocation mode: %V", mode);
|
|
return NULL; /* hush the compiler */
|
|
}
|
|
if (failok) res = scheme_malloc_fail_ok(mf,size); else res = mf(size);
|
|
if (((from != NULL) || (foff != 0)) && (res != NULL))
|
|
memcpy(res, W_OFFSET(from, foff), size);
|
|
if (SAME_OBJ(mode, raw_sym))
|
|
return scheme_make_foreign_external_cpointer(res);
|
|
else
|
|
return scheme_make_foreign_cpointer(res);
|
|
}
|
|
|
|
/* (end-stubborn-change ptr) */
|
|
@cdefine[end-stubborn-change 1]{
|
|
void *ptr;
|
|
long poff;
|
|
if (!SCHEME_FFIANYPTRP(argv[0]))
|
|
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
|
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
|
|
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
|
if ((ptr == NULL) && (poff == 0))
|
|
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
|
|
scheme_end_stubborn_change(W_OFFSET(ptr, poff));
|
|
return scheme_void;
|
|
}
|
|
|
|
/* (free ptr) */
|
|
/* This is useful for raw-malloced objects, including objects from C libraries
|
|
* that the library is mallocing itself. */
|
|
@cdefine[free 1]{
|
|
void *ptr;
|
|
long poff;
|
|
if (!SCHEME_FFIANYPTRP(argv[0]))
|
|
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
|
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
|
|
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
|
if ((ptr == NULL) && (poff == 0))
|
|
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
|
|
free(W_OFFSET(ptr, poff));
|
|
return scheme_void;
|
|
}
|
|
|
|
/* (malloc-immobile-cell v) */
|
|
@cdefine[malloc-immobile-cell 1]{
|
|
return scheme_make_foreign_external_cpointer(scheme_malloc_immobile_box(argv[0]));
|
|
}
|
|
|
|
/* (free-immobile-cell b) */
|
|
@cdefine[free-immobile-cell 1]{
|
|
void *ptr;
|
|
long poff;
|
|
if (!SCHEME_FFIANYPTRP(argv[0]))
|
|
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
|
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
|
|
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
|
if ((ptr == NULL) && (poff == 0))
|
|
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
|
|
scheme_free_immobile_box((void **)W_OFFSET(ptr, poff));
|
|
return scheme_void;
|
|
}
|
|
|
|
#define C_LONG_TYPE_STR "exact integer that fits a C long"
|
|
|
|
/* (ptr-add cptr offset-k [type])
|
|
* Adds an offset to a pointer, returning an offset_cpointer value
|
|
* (ptr-add! cptr offset-k [type])
|
|
* Modifies an existing offset_cpointer value by adjusting its offset field,
|
|
* returns void
|
|
*/
|
|
static Scheme_Object *do_ptr_add(const char *who, int is_bang,
|
|
int argc, Scheme_Object **argv)
|
|
{
|
|
long noff;
|
|
if (is_bang) {
|
|
if (!SCHEME_CPOINTER_W_OFFSET_P(argv[0]))
|
|
scheme_wrong_type(who, "offset-cpointer", 0, argc, argv);
|
|
} else {
|
|
if (!SCHEME_FFIANYPTRP(argv[0]))
|
|
scheme_wrong_type(who, "cpointer", 0, argc, argv);
|
|
}
|
|
if (!scheme_get_int_val(argv[1], &noff))
|
|
scheme_wrong_type(who, C_LONG_TYPE_STR, 1, argc, argv);
|
|
if (argc > 2) {
|
|
if (SCHEME_CTYPEP(argv[2])) {
|
|
long size;
|
|
size = ctype_sizeof(argv[2]);
|
|
if (size <= 0) scheme_wrong_type(who, "non-void-C-type", 2, argc, argv);
|
|
noff = noff * size;
|
|
} else
|
|
scheme_wrong_type(who, "C-type", 2, argc, argv);
|
|
}
|
|
if (is_bang) {
|
|
((Scheme_Offset_Cptr*)(argv[0]))->offset += noff;
|
|
return scheme_void;
|
|
} else {
|
|
if (SCHEME_CPTRP(argv[0]) && (SCHEME_CPTR_FLAGS(argv[0]) & 0x1))
|
|
return scheme_make_offset_external_cptr
|
|
(SCHEME_FFIANYPTR_VAL(argv[0]),
|
|
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
|
|
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
|
|
else
|
|
return scheme_make_offset_cptr
|
|
(SCHEME_FFIANYPTR_VAL(argv[0]),
|
|
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
|
|
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
|
|
}
|
|
}
|
|
|
|
/* (ptr-add cptr offset-k [type]) */
|
|
@cdefine[ptr-add 2 3]{return do_ptr_add(MYNAME, 0, argc, argv);}
|
|
/* (ptr-add! cptr offset-k [type]) */
|
|
@cdefine[ptr-add! 2 3]{return do_ptr_add(MYNAME, 1, argc, argv);}
|
|
|
|
/* (offset-ptr? x) */
|
|
/* Returns #t if the argument is a cpointer with an offset */
|
|
@cdefine[offset-ptr? 1 1]{
|
|
return (SCHEME_CPOINTER_W_OFFSET_P(argv[0])) ? scheme_true : scheme_false;
|
|
}
|
|
|
|
/* (ptr-offset ptr) */
|
|
/* Returns the offset of a cpointer (0 if it's not an offset pointer) */
|
|
@cdefine[ptr-offset 1 1]{
|
|
if (!SCHEME_FFIANYPTRP(argv[0]))
|
|
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
|
return scheme_make_integer_value(SCHEME_FFIANYPTR_OFFSET(argv[0]));
|
|
}
|
|
|
|
/* (set-ptr-offset! ptr offset [type]) */
|
|
/* Sets the offset of an offset-cpointer (possibly multiplied by the size of
|
|
* the given ctype) */
|
|
@cdefine[set-ptr-offset! 2 3]{
|
|
long noff;
|
|
if (!SCHEME_CPOINTER_W_OFFSET_P(argv[0]))
|
|
scheme_wrong_type(MYNAME, "offset-cpointer", 0, argc, argv);
|
|
if (!scheme_get_int_val(argv[1], &noff)) {
|
|
scheme_wrong_type(MYNAME, C_LONG_TYPE_STR, 1, argc, argv);
|
|
}
|
|
if (argc > 2) {
|
|
if (SCHEME_CTYPEP(argv[2])) {
|
|
long size;
|
|
if (NULL == get_ctype_base(argv[2]))
|
|
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
|
|
size = ctype_sizeof(argv[2]);
|
|
if (size <= 0)
|
|
scheme_wrong_type(MYNAME, "non-void-C-type", 2, argc, argv);
|
|
noff = noff * size;
|
|
} else
|
|
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
|
|
}
|
|
((Scheme_Offset_Cptr*)(argv[0]))->offset = noff;
|
|
return scheme_void;
|
|
}
|
|
|
|
/* (mem{move,cpy} dest-ptr [dest-offset] src-ptr [src-offset] count [ctype])
|
|
* Copies count * sizeof(ctype) bytes
|
|
* from src-ptr + src-offset * sizeof(ctype)
|
|
* to dest-ptr + dest-offset * sizeof(ctype).
|
|
* --or--
|
|
* (memset dest-ptr [dest-offset] byte count [ctype])
|
|
* Sets count * sizeof(ctype) bytes to byte
|
|
* at dest-ptr + dest-offset * sizeof(ctype) */
|
|
static Scheme_Object *do_memop(const char *who, int mode,
|
|
int argc, Scheme_Object **argv)
|
|
/* mode 0=>memset, 1=>memmove, 2=>memcpy */
|
|
{
|
|
void *src = NULL, *dest = NULL;
|
|
long soff = 0, doff = 0, count, v, mult = 0;
|
|
int i, j, ch = 0, argc1 = argc;
|
|
|
|
/* arg parsing: last optional ctype, then count, then fill byte for memset,
|
|
* then the first and second pointer+offset pair. */
|
|
|
|
/* get the optional last ctype multiplier */
|
|
if (SCHEME_CTYPEP(argv[argc1-1])) {
|
|
argc1--;
|
|
mult = ctype_sizeof(argv[argc1]);
|
|
if (mult <= 0)
|
|
scheme_wrong_type(who, "non-void-C-type", argc1, argc, argv);
|
|
}
|
|
|
|
/* get the count argument */
|
|
argc1--;
|
|
if ((!scheme_get_int_val(argv[argc1], &count)) || (count < 0))
|
|
scheme_wrong_type(who, "count as " C_LONG_TYPE_STR, argc1, argc, argv);
|
|
if (mult) count *= mult;
|
|
|
|
/* get the fill byte for memset */
|
|
if (!mode) {
|
|
argc1--;
|
|
ch = SCHEME_INTP(argv[argc1]) ? SCHEME_INT_VAL(argv[argc1]) : -1;
|
|
if ((ch < 0) || (ch > 255))
|
|
scheme_wrong_type(who, "byte", argc1, argc, argv);
|
|
}
|
|
|
|
/* get the two pointers + offsets */
|
|
i = 0;
|
|
for (j=0; j<2; j++) {
|
|
if (!mode && j==1) break; /* memset needs only a dest argument */
|
|
if (!(i<argc1))
|
|
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
|
"%s: missing a pointer argument for %s",
|
|
who, (j == 0 ? "destination" : "source"));
|
|
if (!SCHEME_FFIANYPTRP(argv[i]))
|
|
scheme_wrong_type(who, "cpointer", i, argc, argv);
|
|
switch (j) {
|
|
case 0: dest = SCHEME_FFIANYPTR_VAL(argv[i]);
|
|
doff = SCHEME_FFIANYPTR_OFFSET(argv[i]);
|
|
break;
|
|
case 1: src = SCHEME_FFIANYPTR_VAL(argv[i]);
|
|
soff = SCHEME_FFIANYPTR_OFFSET(argv[i]);
|
|
break;
|
|
}
|
|
i++;
|
|
if ((i<argc1) && SCHEME_EXACT_INTEGERP(argv[i])) {
|
|
if (!scheme_get_int_val(argv[i], &v))
|
|
scheme_wrong_type(who, C_LONG_TYPE_STR, i, argc, argv);
|
|
if (mult) v *= mult;
|
|
switch (j) {
|
|
case 0: doff += v; break;
|
|
case 1: soff += v; break;
|
|
}
|
|
i++;
|
|
}
|
|
}
|
|
|
|
/* verify that there are no unused leftovers */
|
|
if (!(i==argc1))
|
|
scheme_arg_mismatch(who, "unexpected extra argument: ", argv[i]);
|
|
|
|
switch (mode) {
|
|
case 0: memset (W_OFFSET(dest, doff), ch, count); break;
|
|
case 1: memmove(W_OFFSET(dest, doff), W_OFFSET(src, soff), count); break;
|
|
case 2: memcpy (W_OFFSET(dest, doff), W_OFFSET(src, soff), count); break;
|
|
}
|
|
|
|
return scheme_void;
|
|
}
|
|
|
|
@cdefine[vector->cpointer 1]{
|
|
if (!SCHEME_VECTORP(argv[0]))
|
|
scheme_wrong_type(MYNAME, "vector", 0, argc, argv);
|
|
return scheme_make_offset_cptr(argv[0], (long)SCHEME_VEC_ELS((Scheme_Object *)0x0), NULL);
|
|
}
|
|
|
|
@cdefine[flvector->cpointer 1]{
|
|
if (!SCHEME_FLVECTORP(argv[0]))
|
|
scheme_wrong_type(MYNAME, "flvector", 0, argc, argv);
|
|
return scheme_make_offset_cptr(argv[0], (long)SCHEME_FLVEC_ELS((Scheme_Object *)0x0), NULL);
|
|
}
|
|
|
|
@cdefine[memset 3 5]{return do_memop(MYNAME, 0, argc, argv);}
|
|
@cdefine[memmove 3 6]{return do_memop(MYNAME, 1, argc, argv);}
|
|
@cdefine[memcpy 3 6]{return do_memop(MYNAME, 2, argc, argv);}
|
|
|
|
@defsymbols[abs]
|
|
|
|
/* (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. */
|
|
@cdefine[ptr-ref 2 4]{
|
|
int size=0; void *ptr; Scheme_Object *base;
|
|
long delta;
|
|
|
|
if (!SCHEME_FFIANYPTRP(argv[0]))
|
|
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
|
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
|
|
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
|
if ((ptr == NULL) && (delta == 0))
|
|
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
|
|
if (NULL == (base = get_ctype_base(argv[1])))
|
|
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
|
|
size = ctype_sizeof(base);
|
|
|
|
if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
|
|
if (SCHEME_FFIOBJP(argv[0])) {
|
|
/* The ffiobj pointer is the function pointer. */
|
|
ptr = argv[0];
|
|
delta = (long)&(((ffi_obj_struct*)0x0)->obj);
|
|
}
|
|
}
|
|
|
|
if (size < 0) {
|
|
/* should not happen */
|
|
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
|
|
} else if (size == 0) {
|
|
scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
|
|
}
|
|
|
|
if (argc > 3) {
|
|
if (!SAME_OBJ(argv[2],abs_sym))
|
|
scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
|
|
if (!SCHEME_INTP(argv[3]))
|
|
scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
|
|
delta += SCHEME_INT_VAL(argv[3]);
|
|
} else if (argc > 2) {
|
|
if (!SCHEME_INTP(argv[2]))
|
|
scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
|
|
if (!size)
|
|
scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
|
|
delta += (size * SCHEME_INT_VAL(argv[2]));
|
|
}
|
|
return C2SCHEME(argv[1], ptr, delta, 0);
|
|
}
|
|
|
|
/* (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. */
|
|
@cdefine[ptr-set! 3 5]{
|
|
int size=0; void *ptr;
|
|
long delta;
|
|
Scheme_Object *val = argv[argc-1], *base;
|
|
if (!SCHEME_FFIANYPTRP(argv[0]))
|
|
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
|
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
|
|
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
|
if ((ptr == NULL) && (delta == 0))
|
|
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
|
|
if (NULL == (base = get_ctype_base(argv[1])))
|
|
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
|
|
size = ctype_sizeof(base);
|
|
|
|
if (size < 0) {
|
|
/* should not happen */
|
|
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
|
|
} else if (size == 0) {
|
|
scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
|
|
}
|
|
|
|
if (argc > 4) {
|
|
if (!SAME_OBJ(argv[2],abs_sym))
|
|
scheme_wrong_type(MYNAME, "'abs", 2, argc, argv);
|
|
if (!SCHEME_INTP(argv[3]))
|
|
scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
|
|
delta += SCHEME_INT_VAL(argv[3]);
|
|
} else if (argc > 3) {
|
|
if (!SCHEME_INTP(argv[2]))
|
|
scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
|
|
if (!size)
|
|
scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
|
|
delta += (size * SCHEME_INT_VAL(argv[2]));
|
|
}
|
|
SCHEME2C(argv[1], ptr, delta, val, NULL, NULL, 0);
|
|
return scheme_void;
|
|
}
|
|
|
|
/* (ptr-equal? cpointer cpointer) -> boolean */
|
|
@cdefine[ptr-equal? 2 2]{
|
|
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;
|
|
}
|
|
|
|
/* (make-sized-byte-string cpointer len) */
|
|
@cdefine[make-sized-byte-string 2 2]{
|
|
/* Warning: no copying is done so it is possible to share string contents. */
|
|
/* Warning: if source ptr has a offset, resulting string object uses shifted
|
|
* pointer.
|
|
* (Should use real byte-strings with new version.) */
|
|
long len;
|
|
if (!SCHEME_FFIANYPTRP(argv[0]))
|
|
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
|
if (!scheme_get_int_val(argv[1],&len))
|
|
scheme_wrong_type(MYNAME, "integer in a C long range", 1, argc, argv);
|
|
if (SCHEME_FALSEP(argv[0])) return scheme_false;
|
|
else return
|
|
scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(argv[0]),
|
|
len, 0);
|
|
}
|
|
|
|
/* *** Calling Scheme code while the GC is working leads to subtle bugs, so
|
|
*** this is implemented now in Scheme using will executors. */
|
|
|
|
/* internal: apply Scheme finalizer */
|
|
void do_scm_finalizer(void *p, void *finalizer)
|
|
{
|
|
Scheme_Object *f = (Scheme_Object*)finalizer;
|
|
if (!SCHEME_FALSEP(f)) _scheme_apply(f, 1, (Scheme_Object**)(void*)(&p));
|
|
}
|
|
void do_ptr_finalizer(void *p, void *finalizer)
|
|
{
|
|
Scheme_Object *f = (Scheme_Object*)finalizer;
|
|
Scheme_Object *ptr;
|
|
if (p == NULL) return;
|
|
ptr = scheme_make_cptr(p,NULL);
|
|
if (!SCHEME_FALSEP(f)) _scheme_apply(f, 1, (Scheme_Object**)(&ptr));
|
|
/* don't leave dangling references! */
|
|
SCHEME_CPTR_VAL(ptr) = NULL;
|
|
ptr = NULL;
|
|
}
|
|
|
|
/* (register-finalizer ptrobj finalizer ['pointer]) -> old-finalizer */
|
|
/* The finalizer is called by the primitive finalizer mechanism, make sure */
|
|
/* no references to the object are recreated. #f means erase existing */
|
|
/* finalizer if any.*/
|
|
/* If no 'pointer argument is given, this is can be used with any Scheme */
|
|
/* object, and the finalizer will be called with it. If an additional */
|
|
/* 'pointer argument of 'pointer is given, the object must be a cpointer */
|
|
/* object, the finalizer will be invoked when the pointer itself is */
|
|
/* unreachable, and it will get a new cpointer object that points to it. */
|
|
/* (Only needed in cases where pointer aliases might be created.) */
|
|
/*
|
|
@add-prefix[" * "]{
|
|
defsymbols[pointer]
|
|
cdefine[register-finalizer 2 3]{
|
|
void *ptr, *old = NULL;
|
|
int ptrsym = (argc == 3 && argv[2] == pointer_sym);
|
|
if (ptrsym) {
|
|
if (!SCHEME_FFIANYPTRP(argv[0]))
|
|
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
|
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
|
|
if (ptr == NULL)
|
|
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
|
|
} else {
|
|
if (argc == 3)
|
|
scheme_wrong_type(MYNAME, "pointer-mode", 2, argc, argv);
|
|
ptr = argv[0];
|
|
}
|
|
if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1])))
|
|
scheme_wrong_type(MYNAME, "procedure-or-false", 1, argc, argv);
|
|
scheme_register_finalizer
|
|
(ptr, (ptrsym ? do_ptr_finalizer : do_scm_finalizer),
|
|
argv[1], NULL, &old);
|
|
return (old == NULL) ? scheme_false : (Scheme_Object*)old;
|
|
}}
|
|
*/
|
|
|
|
/*****************************************************************************/
|
|
/* Calling foreign function objects */
|
|
|
|
#define MAX_QUICK_ARGS 16
|
|
|
|
typedef void(*VoidFun)();
|
|
|
|
Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|
/* data := {name, c-function, itypes, otype, cif} */
|
|
{
|
|
/* The name is not currently used */
|
|
/* char *name = SCHEME_BYTE_STR_VAL(SCHEME_VEC_ELS(data)[0]); */
|
|
void *c_func = (void*)(SCHEME_VEC_ELS(data)[1]);
|
|
Scheme_Object *itypes = SCHEME_VEC_ELS(data)[2];
|
|
Scheme_Object *otype = SCHEME_VEC_ELS(data)[3];
|
|
Scheme_Object *base;
|
|
ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]);
|
|
long cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]);
|
|
int save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]);
|
|
int nargs = cif->nargs;
|
|
/* When the foreign function is called, we need an array (ivals) of nargs
|
|
* ForeignAny objects to store the actual C values that are created, and we
|
|
* need another array (avalues) for the pointers to these values (this is
|
|
* what libffi actually uses). To make things more fun, ForeignAny is
|
|
* problematic for the precise GC, since it is sometimes a pointer and
|
|
* sometime not. To deal with this, while converting argv objects into
|
|
* ivals, scheme_to_c will save pointer values in avalues, so the GC can,
|
|
* ignore ivals -- just before we reach the actual call, avalues is
|
|
* overwritten, but from that point on it is all C code so there is no
|
|
* problem. Hopefully.
|
|
* (Things get complicated if the C call can involve GC (usually due to a
|
|
* Scheme callback), but then the programmer need to arrange for pointers
|
|
* that cannot move. Because of all this, the *only* array that should not
|
|
* be ignored by the GC is avalues.)
|
|
*/
|
|
GC_CAN_IGNORE ForeignAny *ivals, oval;
|
|
void **avalues, *p, *newp, *tmp;
|
|
GC_CAN_IGNORE ForeignAny stack_ivals[MAX_QUICK_ARGS];
|
|
void *stack_avalues[MAX_QUICK_ARGS];
|
|
long stack_offsets[MAX_QUICK_ARGS];
|
|
int i;
|
|
long basetype, offset, *offsets;
|
|
if (nargs <= MAX_QUICK_ARGS) {
|
|
ivals = stack_ivals;
|
|
avalues = stack_avalues;
|
|
offsets = stack_offsets;
|
|
} else {
|
|
ivals = malloc(nargs * sizeof(ForeignAny));
|
|
avalues = scheme_malloc(nargs * sizeof(void*));
|
|
offsets = scheme_malloc_atomic(nargs * sizeof(long));
|
|
}
|
|
/* iterate on input values and types */
|
|
for (i=0; i<nargs; i++, itypes=SCHEME_CDR(itypes)) {
|
|
/* convert argv[i] according to current itype */
|
|
offset = 0;
|
|
p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype,
|
|
&offset, 0);
|
|
if ((p != NULL) || offset) {
|
|
avalues[i] = p;
|
|
ivals[i].x_fixnum = basetype; /* remember the base type */
|
|
} else {
|
|
avalues[i] = NULL;
|
|
}
|
|
offsets[i] = offset;
|
|
}
|
|
base = get_ctype_base(otype); /* verified below, so cannot be NULL */
|
|
/* If this is a struct return value, then need to malloc in any case, even if
|
|
* the size is smaller than ForeignAny, because this value will be
|
|
* returned. */
|
|
if (CTYPE_PRIMLABEL(base) == FOREIGN_struct) {
|
|
/* need to have p be a pointer that is invisible to the GC */
|
|
p = malloc(CTYPE_PRIMTYPE(base)->size);
|
|
newp = scheme_malloc_atomic(CTYPE_PRIMTYPE(base)->size);
|
|
} else {
|
|
p = &oval;
|
|
newp = NULL;
|
|
}
|
|
/* We finished with all possible mallocs, clear up the avalues and offsets
|
|
* mess */
|
|
for (i=0; i<nargs; i++) {
|
|
if ((avalues[i] == NULL) && !offsets[i]) /* if this was a non-pointer... */
|
|
avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
|
|
else if (ivals[i].x_fixnum != FOREIGN_struct) { /* if *not* a struct... */
|
|
/* ... set the ivals pointer (pointer type doesn't matter) and avalues */
|
|
ivals[i].x_pointer = avalues[i];
|
|
avalues[i] = &(ivals[i]);
|
|
}
|
|
/* Otherwise it was a struct pointer, and avalues[i] is already fine. */
|
|
/* Add offset, if any: */
|
|
if (offsets[i] != 0) {
|
|
ivals[i].x_pointer = (char *)ivals[i].x_pointer + offsets[i];
|
|
}
|
|
}
|
|
/* Finally, call the function */
|
|
ffi_call(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues);
|
|
if (save_errno != 0) save_errno_values(save_errno);
|
|
if (ivals != stack_ivals) free(ivals);
|
|
ivals = NULL; /* no need now to hold on to this */
|
|
for (i=0; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */
|
|
avalues = NULL;
|
|
switch (CTYPE_PRIMLABEL(base)) {
|
|
case FOREIGN_struct:
|
|
memcpy(newp, p, CTYPE_PRIMTYPE(base)->size);
|
|
free(p);
|
|
p = newp;
|
|
break;
|
|
default:
|
|
/* not sure why this code is here, looks fine to remove this case */
|
|
if (CTYPE_PRIMTYPE(base) == &ffi_type_pointer) {
|
|
tmp = ((void**)p)[0];
|
|
p = &tmp;
|
|
}
|
|
break;
|
|
}
|
|
return C2SCHEME(otype, p, 0, 1);
|
|
}
|
|
|
|
/* see below */
|
|
void free_fficall_data(void *ignored, void *p)
|
|
{
|
|
free(((ffi_cif*)p)->arg_types);
|
|
free(p);
|
|
}
|
|
|
|
/* (ffi-call ffi-obj in-types out-type [abi save-errno?]) -> (in-types -> out-value) */
|
|
/* the real work is done by ffi_do_call above */
|
|
@cdefine[ffi-call 3 5]{
|
|
static Scheme_Object *ffi_name_prefix = NULL;
|
|
Scheme_Object *itypes = argv[1];
|
|
Scheme_Object *otype = argv[2];
|
|
Scheme_Object *obj, *data, *p, *base;
|
|
ffi_abi abi;
|
|
long ooff;
|
|
GC_CAN_IGNORE ffi_type *rtype, **atypes;
|
|
GC_CAN_IGNORE ffi_cif *cif;
|
|
int i, nargs, save_errno;
|
|
MZ_REGISTER_STATIC(ffi_name_prefix);
|
|
if (!ffi_name_prefix)
|
|
ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:");
|
|
if (!SCHEME_FFIANYPTRP(argv[0]))
|
|
scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv);
|
|
obj = SCHEME_FFIANYPTR_VAL(argv[0]);
|
|
ooff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
|
if ((obj == NULL) && (ooff == 0))
|
|
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
|
|
nargs = scheme_proper_list_length(itypes);
|
|
if (nargs < 0)
|
|
scheme_wrong_type(MYNAME, "proper list", 1, argc, argv);
|
|
if (NULL == (base = get_ctype_base(otype)))
|
|
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
|
|
rtype = CTYPE_PRIMTYPE(base);
|
|
abi = GET_ABI(MYNAME,3);
|
|
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;
|
|
atypes = malloc(nargs * sizeof(ffi_type*));
|
|
for (i=0, p=itypes; i<nargs; i++, p=SCHEME_CDR(p)) {
|
|
if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
|
|
scheme_wrong_type(MYNAME, "list-of-C-types", 1, argc, argv);
|
|
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
|
|
scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv);
|
|
atypes[i] = CTYPE_PRIMTYPE(base);
|
|
}
|
|
cif = malloc(sizeof(ffi_cif));
|
|
if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
|
|
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
|
|
data = scheme_make_vector(7, NULL);
|
|
p = scheme_append_byte_string
|
|
(ffi_name_prefix,
|
|
scheme_make_byte_string_without_copying
|
|
(SCHEME_FFIOBJP(argv[0]) ?
|
|
((ffi_obj_struct*)(argv[0]))->name : "proc"));
|
|
SCHEME_VEC_ELS(data)[0] = p;
|
|
SCHEME_VEC_ELS(data)[1] = obj;
|
|
SCHEME_VEC_ELS(data)[2] = itypes;
|
|
SCHEME_VEC_ELS(data)[3] = otype;
|
|
SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif;
|
|
SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff);
|
|
SCHEME_VEC_ELS(data)[6] = scheme_make_integer(save_errno);
|
|
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);
|
|
}
|
|
|
|
/*****************************************************************************/
|
|
/* Scheme callbacks */
|
|
|
|
void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
|
|
{
|
|
ffi_callback_struct *data;
|
|
Scheme_Object *argv_stack[MAX_QUICK_ARGS];
|
|
int argc = cif->nargs, i;
|
|
Scheme_Object **argv, *p, *v;
|
|
#ifdef MZ_PRECISE_GC
|
|
{
|
|
void *tmp;
|
|
tmp = *((void**)userdata);
|
|
data = (ffi_callback_struct*)(SCHEME_WEAK_BOX_VAL(tmp));
|
|
if (data == NULL) scheme_signal_error("callback lost");
|
|
}
|
|
#else
|
|
data = (ffi_callback_struct*)userdata;
|
|
#endif
|
|
if (argc <= MAX_QUICK_ARGS)
|
|
argv = argv_stack;
|
|
else
|
|
argv = scheme_malloc(argc * sizeof(Scheme_Object*));
|
|
if (data->call_in_scheduler)
|
|
scheme_start_in_scheduler();
|
|
for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
|
|
v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0);
|
|
argv[i] = v;
|
|
}
|
|
p = _scheme_apply(data->proc, argc, argv);
|
|
SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1);
|
|
if (data->call_in_scheduler)
|
|
scheme_end_in_scheduler();
|
|
}
|
|
|
|
/* see ffi-callback below */
|
|
typedef struct closure_and_cif_struct {
|
|
ffi_closure closure;
|
|
ffi_cif cif;
|
|
#ifdef MZ_PRECISE_GC
|
|
struct immobile_box *data;
|
|
#else
|
|
void *data;
|
|
#endif
|
|
} closure_and_cif;
|
|
/* free the above */
|
|
void free_cl_cif_args(void *ignored, void *p)
|
|
{
|
|
/*
|
|
scheme_warning("Releasing cl+cif+args %V %V (%d)",
|
|
ignored,
|
|
(((closure_and_cif*)p)->data),
|
|
SAME_OBJ(ignored,(((closure_and_cif*)p)->data)));
|
|
*/
|
|
#ifdef MZ_PRECISE_GC
|
|
GC_free_immobile_box((void**)(((closure_and_cif*)p)->data));
|
|
#endif
|
|
scheme_free_code(p);
|
|
}
|
|
|
|
/* (ffi-callback scheme-proc in-types out-type [abi]) -> ffi-callback */
|
|
/* the treatment of in-types and out-types is similar to that in ffi-call */
|
|
/* the real work is done by ffi_do_callback above */
|
|
@cdefine[ffi-callback 3 5]{
|
|
ffi_callback_struct *data;
|
|
Scheme_Object *itypes = argv[1];
|
|
Scheme_Object *otype = argv[2];
|
|
Scheme_Object *p, *base;
|
|
ffi_abi abi;
|
|
int nargs, i;
|
|
/* ffi_closure objects are problematic when used with a moving GC. The
|
|
* problem is that memory that is GC-visible can move at any time. The
|
|
* solution is to use an immobile-box, which an immobile pointer (in a simple
|
|
* malloced block), which points to the ffi_callback_struct that contains the
|
|
* relevant Scheme call details. Another minor complexity is that an
|
|
* immobile box serves as a reference for the GC, which means that nothing
|
|
* will ever get collected: and the solution for this is to stick a weak-box
|
|
* in the chain. Users need to be aware of GC issues, and need to keep a
|
|
* reference to the callback object to avoid releasing the whole thing --
|
|
* when that reference is lost, the ffi_callback_struct will be GCed, and a
|
|
* finalizer will free() the malloced memory. Everything on the malloced
|
|
* part is allocated in one block, to make it easy to free. The final layout
|
|
* of the various objects is:
|
|
*
|
|
* <<======malloc======>> : <<===========scheme_malloc===============>>
|
|
* :
|
|
* ffi_closure <------------------------\
|
|
* | | : |
|
|
* | | : |
|
|
* | \--> immobile ----> weak |
|
|
* | box : box |
|
|
* | : | |
|
|
* | : | |
|
|
* | : \--> ffi_callback_struct
|
|
* | : | |
|
|
* V : | \-----> Scheme Closure
|
|
* cif ---> atypes : |
|
|
* : \--------> input/output types
|
|
*/
|
|
GC_CAN_IGNORE ffi_type *rtype, **atypes;
|
|
GC_CAN_IGNORE ffi_cif *cif;
|
|
GC_CAN_IGNORE ffi_closure *cl;
|
|
GC_CAN_IGNORE closure_and_cif *cl_cif_args;
|
|
if (!SCHEME_PROCP(argv[0]))
|
|
scheme_wrong_type(MYNAME, "procedure", 0, argc, argv);
|
|
nargs = scheme_proper_list_length(itypes);
|
|
if (nargs < 0)
|
|
scheme_wrong_type(MYNAME, "proper list", 1, argc, argv);
|
|
if (NULL == (base = get_ctype_base(otype)))
|
|
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
|
|
rtype = CTYPE_PRIMTYPE(base);
|
|
abi = GET_ABI(MYNAME,3);
|
|
/* malloc space for everything needed, so a single free gets rid of this */
|
|
cl_cif_args = scheme_malloc_code(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*));
|
|
cl = &(cl_cif_args->closure); /* cl is the same as cl_cif_args */
|
|
cif = &(cl_cif_args->cif);
|
|
atypes = (ffi_type **)(((char*)cl_cif_args) + sizeof(closure_and_cif));
|
|
for (i=0, p=itypes; i<nargs; i++, p=SCHEME_CDR(p)) {
|
|
if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
|
|
scheme_wrong_type(MYNAME, "list-of-C-types", 1, argc, argv);
|
|
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
|
|
scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv);
|
|
atypes[i] = CTYPE_PRIMTYPE(base);
|
|
}
|
|
if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
|
|
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
|
|
@cmake["data" ffi-callback
|
|
"cl_cif_args" "argv[0]" "argv[1]" "argv[2]"
|
|
"((argc > 4) && SCHEME_TRUEP(argv[4]))"]
|
|
@@@IFDEF{MZ_PRECISE_GC}{
|
|
{
|
|
/* put data in immobile, weak box */
|
|
void **tmp;
|
|
tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0));
|
|
cl_cif_args->data = (struct immobile_box*)tmp;
|
|
}
|
|
}{
|
|
cl_cif_args->data = (void*)data;
|
|
}
|
|
if (ffi_prep_closure(cl, cif, &ffi_do_callback, (void*)(cl_cif_args->data))
|
|
!= FFI_OK)
|
|
scheme_signal_error
|
|
("internal error: ffi_prep_closure did not return FFI_OK");
|
|
scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL);
|
|
return (Scheme_Object*)data;
|
|
}
|
|
|
|
/*****************************************************************************/
|
|
|
|
static void save_errno_values(int kind)
|
|
{
|
|
Scheme_Thread *p = scheme_current_thread;
|
|
|
|
if (kind == 2) {
|
|
long v = 0;
|
|
@@IFDEF{WINDOWS_DYNAMIC_LOAD}{
|
|
v = GetLastError();
|
|
}
|
|
p->saved_errno = v;
|
|
return;
|
|
}
|
|
|
|
p->saved_errno = errno;
|
|
}
|
|
|
|
@cdefine[saved-errno 0]{
|
|
Scheme_Thread *p = scheme_current_thread;
|
|
return scheme_make_integer_value(p->saved_errno);
|
|
}
|
|
|
|
@cdefine[lookup-errno 1]{
|
|
Scheme_Object *v = argv[0];
|
|
@(let* ([errnos '(EINTR EEXIST EAGAIN)]
|
|
[syms (let loop ([errnos errnos])
|
|
(if (null? (cdr errnos))
|
|
(format "or '~a" (car errnos))
|
|
(format "'~a, ~a" (car errnos) (loop (cdr errnos)))))])
|
|
@list{
|
|
if (SCHEME_SYMBOLP(v) && !SCHEME_SYM_WEIRDP(v)) {
|
|
@(add-newlines
|
|
(for/list ([e errnos])
|
|
@string-append{
|
|
if (!strcmp("@symbol->string[e]", SCHEME_SYM_VAL(v)))
|
|
return scheme_make_integer(@symbol->string[e]);
|
|
}))
|
|
}
|
|
scheme_wrong_type(MYNAME, "@syms",0, argc, argv);
|
|
return NULL;
|
|
})
|
|
}
|
|
|
|
/*****************************************************************************/
|
|
|
|
void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
|
|
{
|
|
char *str;
|
|
if (!SCHEME_CTYPEP(ctype))
|
|
scheme_wrong_type("Scheme->C", "C-type", 0, 1, &ctype);
|
|
if (CTYPE_PRIMP(ctype)) {
|
|
scheme_print_bytes(pp, "#<ctype:", 0, 8);
|
|
ctype = CTYPE_BASETYPE(ctype);
|
|
if (SCHEME_SYMBOLP(ctype)) {
|
|
str = SCHEME_SYM_VAL(ctype);
|
|
scheme_print_bytes(pp, str, 0, strlen(str));
|
|
} else {
|
|
scheme_print_bytes(pp, "cstruct", 0, 7);
|
|
}
|
|
scheme_print_bytes(pp, ">", 0, 1);
|
|
} else {
|
|
scheme_print_bytes(pp, "#<ctype>", 0, 8);
|
|
}
|
|
}
|
|
|
|
/*****************************************************************************/
|
|
/* Initialization */
|
|
|
|
/* types need to be initialized before places can spawn
|
|
* types become entries in the GC mark and fixup tables
|
|
* this function should initialize read-only globals that can be
|
|
* shared without locking */
|
|
void scheme_init_foreign_globals()
|
|
{
|
|
@(maplines (lambda (x)
|
|
@list{@(cadr x)_tag = scheme_make_type("<@(car x)>")})
|
|
(reverse (cstructs)))
|
|
@@IFDEF{MZ_PRECISE_GC}{
|
|
@(maplines (lambda (x)
|
|
@list{GC_register_traversers(@(cadr x)_tag, @(cadr x)_SIZE, @;
|
|
@(cadr x)_MARK, @(cadr x)_FIXUP, 1, 0)})
|
|
(reverse (cstructs)))
|
|
}
|
|
scheme_set_type_printer(ctype_tag, ctype_printer);
|
|
@(maplines (lambda (sym)
|
|
@list{MZ_REGISTER_STATIC(@(cadr sym));
|
|
@(cadr sym) = scheme_intern_symbol("@(car sym)")})
|
|
(reverse (symbols)))
|
|
}
|
|
|
|
void scheme_init_foreign_places() {
|
|
MZ_REGISTER_STATIC(opened_libs);
|
|
opened_libs = scheme_make_hash_table(SCHEME_hash_string);
|
|
}
|
|
|
|
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);
|
|
@(maplines
|
|
(lambda (x)
|
|
(define-values (sname cfun min max) (apply values x))
|
|
@list{scheme_add_global("@sname",
|
|
scheme_make_prim_w_arity(@cfun, "@sname", @min, @max), menv)})
|
|
(reverse (cfunctions)))
|
|
@(map-types
|
|
;; no need for these, at least for now:
|
|
;; MZ_REGISTER_STATIC(@|cname|_sym);
|
|
;; @|cname|_sym = scheme_intern_symbol("@stype");
|
|
@list{s = scheme_intern_symbol("@stype");
|
|
@cmake["t" ctype "s"
|
|
@list{(Scheme_Object*)(void*)(&ffi_type_@ftype)}
|
|
@list{(Scheme_Object*)FOREIGN_@cname}]
|
|
scheme_add_global("_@stype", (Scheme_Object*)t, menv)})
|
|
scheme_finish_primitive_module(menv);
|
|
scheme_protect_primitive_provide(menv, NULL);
|
|
}
|
|
|
|
/*****************************************************************************/
|