add #:save-errno option for foreign-function types
svn: r17299
This commit is contained in:
Matthew Flatt
parent
d13057d8c4
commit
87f05fed95
|
|
@ -80,21 +80,27 @@
|
|||
|
||||
;; open : string int -> int
|
||||
(define open
|
||||
(delay-ffi-obj (winize "open") #f (_fun _string _int -> _int)))
|
||||
(delay-ffi-obj (winize "open") #f (_fun #:save-errno 'posix _string _int -> _int)))
|
||||
|
||||
;; close : int -> int
|
||||
(define close
|
||||
(delay-ffi-obj (winize "close") #f (_fun _int -> _int)))
|
||||
(delay-ffi-obj (winize "close") #f (_fun #:save-errno 'posix _int -> _int)))
|
||||
|
||||
;; ftruncate : int int -> int
|
||||
(define ftruncate
|
||||
(if (eq? 'windows (system-type))
|
||||
(delay-ffi-obj "_chsize" #f (_fun _int _llong -> _int))
|
||||
(delay-ffi-obj "ftruncate" #f (_fun _int _llong -> _int))))
|
||||
(delay-ffi-obj "_chsize" #f (_fun #:save-errno 'posix _int _llong -> _int))
|
||||
(delay-ffi-obj "ftruncate" #f (_fun #:save-errno 'posix _int _llong -> _int))))
|
||||
|
||||
;; on-c-fail : int (-> X) int or X
|
||||
(define (on-c-fail val fail-k)
|
||||
(if (> val -1) val (fail-k)))
|
||||
(define (on-c-fail thunk fail-k)
|
||||
(let ([val (thunk)])
|
||||
(cond
|
||||
[(> val -1) val]
|
||||
[(= (saved-errno) (lookup-errno 'EINTR))
|
||||
;; interrupted by a signal; retry
|
||||
(on-c-fail thunk fail-k)]
|
||||
[else (fail-k)])))
|
||||
|
||||
(define scheme_security_check_file
|
||||
(delay-ffi-obj "scheme_security_check_file" #f
|
||||
|
|
@ -115,15 +121,20 @@
|
|||
(if (path? file) (path->string file) file)
|
||||
SCHEME_GUARD_FILE_WRITE)
|
||||
(let ([fd (on-c-fail
|
||||
((force open) file O_WRONLY)
|
||||
(lambda ()
|
||||
((force open) file O_WRONLY))
|
||||
(lambda ()
|
||||
(error 'truncate-file "could not open file")))])
|
||||
(on-c-fail
|
||||
((force ftruncate) fd size)
|
||||
(lambda ()
|
||||
((force ftruncate) fd size))
|
||||
(lambda ()
|
||||
((force close) fd)
|
||||
(error 'truncate-file "could not truncate file")))
|
||||
((force close) fd)
|
||||
(on-c-fail
|
||||
(lambda ()
|
||||
((force close) fd))
|
||||
void)
|
||||
(void))))
|
||||
|
||||
(provide truncate-file)
|
||||
|
|
|
|||
|
|
@ -64,6 +64,7 @@
|
|||
(unsafe malloc) (unsafe free) (unsafe end-stubborn-change)
|
||||
cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!) (unsafe cast)
|
||||
ptr-offset ptr-add! offset-ptr? set-ptr-offset!
|
||||
vector->cpointer flvector->cpointer saved-errno lookup-errno
|
||||
ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string) ctype->layout
|
||||
_void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
|
||||
_fixint _ufixint _fixnum _ufixnum
|
||||
|
|
@ -481,12 +482,13 @@
|
|||
#:abi [abi #f]
|
||||
#:wrapper [wrapper #f]
|
||||
#:keep [keep #f]
|
||||
#:atomic? [atomic? #f])
|
||||
(_cprocedure* itypes otype abi wrapper keep atomic?))
|
||||
#:atomic? [atomic? #f]
|
||||
#:save-errno [errno #f])
|
||||
(_cprocedure* itypes otype abi wrapper keep atomic? errno))
|
||||
|
||||
;; for internal use
|
||||
(define held-callbacks (make-weak-hasheq))
|
||||
(define (_cprocedure* itypes otype abi wrapper keep atomic?)
|
||||
(define (_cprocedure* itypes otype abi wrapper keep atomic? errno)
|
||||
(define-syntax-rule (make-it wrap)
|
||||
(make-ctype _fpointer
|
||||
(lambda (x)
|
||||
|
|
@ -499,7 +501,7 @@
|
|||
(if (or (null? x) (pair? x)) (cons cb x) cb)))]
|
||||
[(procedure? keep) (keep cb)])
|
||||
cb)))
|
||||
(lambda (x) (and x (wrap (ffi-call x itypes otype abi))))))
|
||||
(lambda (x) (and x (wrap (ffi-call x itypes otype abi errno))))))
|
||||
(if wrapper (make-it wrapper) (make-it begin)))
|
||||
|
||||
;; Syntax for the special _fun type:
|
||||
|
|
@ -528,6 +530,7 @@
|
|||
(define abi #f)
|
||||
(define keep #f)
|
||||
(define atomic? #f)
|
||||
(define errno #f)
|
||||
(define inputs #f)
|
||||
(define output #f)
|
||||
(define bind '())
|
||||
|
|
@ -592,10 +595,11 @@
|
|||
(begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))]
|
||||
...
|
||||
[else (err "unknown keyword" (car xs))]))
|
||||
(when (keyword? k) (kwds [#:abi abi] [#:keep keep] [#:atomic? atomic?]))))
|
||||
(when (keyword? k) (kwds [#:abi abi] [#:keep keep] [#:atomic? atomic?] [#:save-errno errno]))))
|
||||
(unless abi (set! abi #'#f))
|
||||
(unless keep (set! keep #'#t))
|
||||
(unless atomic? (set! atomic? #'#f))
|
||||
(unless errno (set! errno #'#f))
|
||||
;; parse known punctuation
|
||||
(set! xs (map (lambda (x)
|
||||
(syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x]))
|
||||
|
|
@ -686,9 +690,9 @@
|
|||
(string->symbol (string-append "ffi-wrapper:" n)))
|
||||
body))])
|
||||
#`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
|
||||
#,abi (lambda (ffi) #,body) #,keep #,atomic?))
|
||||
#,abi (lambda (ffi) #,body) #,keep #,atomic? #,errno))
|
||||
#`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
|
||||
#,abi #f #,keep #,atomic?)))
|
||||
#,abi #f #,keep #,atomic? #,errno)))
|
||||
(syntax-case stx ()
|
||||
[(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))]))
|
||||
|
||||
|
|
@ -1079,6 +1083,7 @@
|
|||
[TAG->list (id "" "->list")]
|
||||
[TAG-ref (id "" "-ref")]
|
||||
[TAG-set! (id "" "-set!")]
|
||||
[TAG->cpointer (id "" "->cpointer")]
|
||||
[_TAG (id "_" "")]
|
||||
[_TAG* (id "_" "*")]
|
||||
[TAGname name]
|
||||
|
|
@ -1125,6 +1130,10 @@
|
|||
(raise-type-error 'TAG->list TAGname v)))
|
||||
(define* (list->TAG l)
|
||||
(make-TAG (list->cblock l type) (length l)))
|
||||
(define* (TAG->cpointer v)
|
||||
(if (TAG? v)
|
||||
(TAG-ptr v)
|
||||
(raise-type-error 'TAG->cpointer TAGname v)))
|
||||
;; same as the _cvector implementation
|
||||
(provide _TAG)
|
||||
(define _TAG*
|
||||
|
|
|
|||
|
|
@ -208,6 +208,7 @@ just aliases for byte-string bindings: @scheme[make-u8vector],
|
|||
[! (mk #'id "vector-set!")]
|
||||
[list-> (mk "list->" #'id "vector")]
|
||||
[->list (mk #'id "vector->list")]
|
||||
[->cpointer (mk #'id "vector->cpointer")]
|
||||
[_vec (mk "_" #'id "vector")])
|
||||
#`(begin
|
||||
(defproc* ([(make [len exact-nonnegative-integer?]) ?]
|
||||
|
|
@ -217,7 +218,8 @@ just aliases for byte-string bindings: @scheme[make-u8vector],
|
|||
[(ref [vec ?][k exact-nonnegative-integer?]) number?]
|
||||
[(! [vec ?][k exact-nonnegative-integer?][val number?]) void?]
|
||||
[(list-> [lst (listof number?)]) ?]
|
||||
[(->list [vec ?]) (listof number?)])
|
||||
[(->list [vec ?]) (listof number?)]
|
||||
[(->cpointer [vec ?]) cpointer?])
|
||||
. desc)
|
||||
;; Big pain: make up relatively-correct source locations
|
||||
;; for pieces in the _vec definition:
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ bindings such as @scheme[foo-bar] for foreign names like
|
|||
]}
|
||||
|
||||
|
||||
@defproc[(list->cblock [lst list>][type ctype?]) any]{
|
||||
@defproc[(list->cblock [lst list?][type ctype?]) any]{
|
||||
|
||||
Allocates a memory block of an appropriate size, and initializes it
|
||||
using values from @scheme[lst] and the given @scheme[type]. The
|
||||
|
|
@ -46,10 +46,34 @@ using values from @scheme[lst] and the given @scheme[type]. The
|
|||
according to the given @scheme[type].}
|
||||
|
||||
|
||||
@defproc[(vector->cblock [vector any/c][type type?]) any]{
|
||||
@defproc[(vector->cblock [vec vector?][type type?]) any]{
|
||||
|
||||
Like @scheme[list->cblock], but for Scheme vectors.}
|
||||
|
||||
|
||||
@defproc[(vector->cpointer [vec vector?]) cpointer?]{
|
||||
|
||||
Returns a pointer to an array of @scheme[_scheme] values, which is the
|
||||
internal representation of @scheme[vec].}
|
||||
|
||||
@defproc[(flvector->cpointer [flvec flvector?]) cpointer?]{
|
||||
|
||||
Returns a pointer to an array of @scheme[_double] values, which is the
|
||||
internal representation of @scheme[flvec].}
|
||||
|
||||
@defproc[(saved-errno) exact-integer?]{
|
||||
|
||||
Returns the value most recently saved (in the current thread) after a
|
||||
foreign call with a non-@scheme[#f] @scheme[#:save-errno] option (see
|
||||
@scheme[_fun] and @scheme[_cprocedure]).}
|
||||
|
||||
@defproc[(lookup-errno [sym (or/c 'EINTR 'EEXIST 'EAGAIN)])
|
||||
exact-integer?]{
|
||||
|
||||
Returns a platform-specific value corresponding to a Posix @tt{errno}
|
||||
symbol. The set of supported symbols is likely to expand in the
|
||||
future.}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
@section{Unsafe Miscellaneous Operations}
|
||||
|
|
|
|||
|
|
@ -342,6 +342,7 @@ the later case, the result is the @scheme[ctype]).}
|
|||
[output-type ctype?]
|
||||
[#:abi abi (or/c symbol/c #f) #f]
|
||||
[#:atomic? atomic? any/c #f]
|
||||
[#:save-errno save-errno (or/c #f 'posix 'windows) #f]
|
||||
[#:wrapper wrapper (or/c #f (procedure? . -> . procedure?))
|
||||
#f]
|
||||
[#:keep keep (or/c boolean? box? (any/c . -> . any/c))
|
||||
|
|
@ -385,6 +386,19 @@ continuation jumps, and its non-tail recursion must be minimal to
|
|||
avoid C-level stack overflow; otherwise, the process may crash or
|
||||
misbehave.
|
||||
|
||||
If @scheme[save-errno] is @scheme['posix], then the value of
|
||||
@as-index{@tt{errno}} is saved (specific to the current thread)
|
||||
immediately after a foreign function returns. The saved value is
|
||||
accessible through @scheme[saved-errno]. If @scheme[save-errno] is
|
||||
@scheme['window], then the value of
|
||||
@as-index{@tt{GetLastError}}@tt{()} is saved for later use via
|
||||
@scheme[saved-errno]; the @scheme['windows] option is available only
|
||||
under Windows. If @scheme[save-errno] is @scheme[#f], no error value
|
||||
is saved automatically. The error-recording support provided by
|
||||
@scheme[save-errno] is needed because the PLT Scheme runtime system
|
||||
may otherwise preempt the current Scheme thread and itself call
|
||||
functions that set error values.
|
||||
|
||||
The optional @scheme[wrapper], if provided, is expected to be a
|
||||
function that can change a callout procedure: when a callout is
|
||||
generated, the wrapper is applied on the newly created primitive
|
||||
|
|
@ -398,7 +412,7 @@ the foreign code before they reach the Scheme procedure, and possibly
|
|||
changes the result values too.
|
||||
|
||||
Sending Scheme functions as callbacks to foreign code is achieved by
|
||||
translating them to a foreign ``closure'', which foreign code can call
|
||||
translating them to a foreign ``closure,'' which foreign code can call
|
||||
as plain C functions. Additional care must be taken in case the
|
||||
foreign code might hold on to the callback function. In these cases
|
||||
you must arrange for the callback value to not be garbage-collected,
|
||||
|
|
@ -450,7 +464,8 @@ values: @itemize[
|
|||
@defform/subs[#:literals (-> :: :)
|
||||
(_fun fun-option ... maybe-args type-spec ... -> type-spec
|
||||
maybe-wrapper)
|
||||
([fun-option (code:line #:abi abi-expr)
|
||||
([fun-option (code:line #:abi abi-expr)
|
||||
(code:line #:save-errno save-errno-expr)
|
||||
(code:line #:keep keep-expr)
|
||||
(code:line #:atomic? atomic?-expr)]
|
||||
[maybe-args code:blank
|
||||
|
|
|
|||
|
|
@ -1,3 +1,6 @@
|
|||
Version 4.2.3.5
|
||||
Added #:save-errno option for foreign-function types
|
||||
|
||||
Version 4.2.3.4
|
||||
Added flvectors
|
||||
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@
|
|||
********************************************/
|
||||
|
||||
#include "schpriv.h"
|
||||
#include <errno.h>
|
||||
|
||||
#ifndef WINDOWS_DYNAMIC_LOAD
|
||||
|
||||
|
|
@ -78,6 +79,8 @@
|
|||
/* 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 */
|
||||
|
||||
|
|
@ -1103,7 +1106,7 @@ typedef struct ffi_callback_struct {
|
|||
Scheme_Object* proc;
|
||||
Scheme_Object* itypes;
|
||||
Scheme_Object* otype;
|
||||
int call_in_scheduler;
|
||||
char call_in_scheduler;
|
||||
} ffi_callback_struct;
|
||||
#define SCHEME_FFICALLBACKP(x) (SCHEME_TYPE(x)==ffi_callback_tag)
|
||||
#define MYNAME "ffi-callback?"
|
||||
|
|
@ -2167,6 +2170,24 @@ static Scheme_Object *do_memop(const char *who, int mode,
|
|||
return scheme_void;
|
||||
}
|
||||
|
||||
#define MYNAME "vector->cpointer"
|
||||
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], (long)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], (long)SCHEME_FLVEC_ELS((Scheme_Object *)0x0), NULL);
|
||||
}
|
||||
#undef MYNAME
|
||||
|
||||
#define MYNAME "memset"
|
||||
static Scheme_Object *foreign_memset(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
|
|
@ -2396,6 +2417,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
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
|
||||
|
|
@ -2472,6 +2494,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
}
|
||||
/* 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 */
|
||||
|
|
@ -2500,7 +2523,7 @@ void free_fficall_data(void *ignored, void *p)
|
|||
free(p);
|
||||
}
|
||||
|
||||
/* (ffi-call ffi-obj in-types out-type [abi]) -> (in-types -> out-value) */
|
||||
/* (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 */
|
||||
#define MYNAME "ffi-call"
|
||||
static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
|
||||
|
|
@ -2513,7 +2536,7 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
|
|||
long ooff;
|
||||
GC_CAN_IGNORE ffi_type *rtype, **atypes;
|
||||
GC_CAN_IGNORE ffi_cif *cif;
|
||||
int i, nargs;
|
||||
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:");
|
||||
|
|
@ -2530,6 +2553,22 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
|
|||
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))))
|
||||
|
|
@ -2541,7 +2580,7 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
|
|||
cif = malloc(sizeof(ffi_cif));
|
||||
if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
|
||||
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
|
||||
data = scheme_make_vector(6, NULL);
|
||||
data = scheme_make_vector(7, NULL);
|
||||
p = scheme_append_byte_string
|
||||
(ffi_name_prefix,
|
||||
scheme_make_byte_string_without_copying
|
||||
|
|
@ -2553,6 +2592,7 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
|
|||
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),
|
||||
|
|
@ -2716,6 +2756,49 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[])
|
|||
|
||||
/*****************************************************************************/
|
||||
|
||||
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();
|
||||
#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
|
||||
|
||||
/*****************************************************************************/
|
||||
|
||||
void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
|
||||
{
|
||||
char *str;
|
||||
|
|
@ -2853,6 +2936,10 @@ void scheme_init_foreign(Scheme_Env *env)
|
|||
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",
|
||||
|
|
@ -2868,9 +2955,13 @@ void scheme_init_foreign(Scheme_Env *env)
|
|||
scheme_add_global("make-sized-byte-string",
|
||||
scheme_make_prim_w_arity(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), menv);
|
||||
scheme_add_global("ffi-call",
|
||||
scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv);
|
||||
scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 5), menv);
|
||||
scheme_add_global("ffi-callback",
|
||||
scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 5), 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);
|
||||
s = scheme_intern_symbol("void");
|
||||
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
|
||||
t->so.type = ctype_tag;
|
||||
|
|
|
|||
|
|
@ -5,11 +5,13 @@ exec mzscheme "$0" > `echo "$0" | sed 's/ssc$/c/'` "$0"
|
|||
|
||||
#lang scribble/text
|
||||
|
||||
@(require "ssc-utils.ss")
|
||||
@(require "ssc-utils.ss"
|
||||
scheme/string)
|
||||
|
||||
@header{foreign.ssc}
|
||||
|
||||
#include "schpriv.h"
|
||||
#include <errno.h>
|
||||
|
||||
@@@IFNDEF{WINDOWS_DYNAMIC_LOAD}{
|
||||
|
||||
|
|
@ -81,6 +83,8 @@ exec mzscheme "$0" > `echo "$0" | sed 's/ssc$/c/'` "$0"
|
|||
/* 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 */
|
||||
|
||||
|
|
@ -933,7 +937,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
|
|||
[proc "Scheme_Object*"]
|
||||
[itypes "Scheme_Object*"]
|
||||
[otype "Scheme_Object*"]
|
||||
[call_in_scheduler "int"]]
|
||||
[call_in_scheduler "char"]]
|
||||
|
||||
/*****************************************************************************/
|
||||
/* Pointer objects */
|
||||
|
|
@ -1569,6 +1573,18 @@ static Scheme_Object *do_memop(const char *who, int mode,
|
|||
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);}
|
||||
|
|
@ -1772,6 +1788,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
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
|
||||
|
|
@ -1848,6 +1865,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
}
|
||||
/* 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 */
|
||||
|
|
@ -1876,9 +1894,9 @@ void free_fficall_data(void *ignored, void *p)
|
|||
free(p);
|
||||
}
|
||||
|
||||
/* (ffi-call ffi-obj in-types out-type [abi]) -> (in-types -> out-value) */
|
||||
/* (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 4]{
|
||||
@cdefine[ffi-call 3 5]{
|
||||
static Scheme_Object *ffi_name_prefix = NULL;
|
||||
Scheme_Object *itypes = argv[1];
|
||||
Scheme_Object *otype = argv[2];
|
||||
|
|
@ -1887,7 +1905,7 @@ void free_fficall_data(void *ignored, void *p)
|
|||
long ooff;
|
||||
GC_CAN_IGNORE ffi_type *rtype, **atypes;
|
||||
GC_CAN_IGNORE ffi_cif *cif;
|
||||
int i, nargs;
|
||||
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:");
|
||||
|
|
@ -1904,6 +1922,22 @@ void free_fficall_data(void *ignored, void *p)
|
|||
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))))
|
||||
|
|
@ -1915,7 +1949,7 @@ void free_fficall_data(void *ignored, void *p)
|
|||
cif = malloc(sizeof(ffi_cif));
|
||||
if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
|
||||
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
|
||||
data = scheme_make_vector(6, NULL);
|
||||
data = scheme_make_vector(7, NULL);
|
||||
p = scheme_append_byte_string
|
||||
(ffi_name_prefix,
|
||||
scheme_make_byte_string_without_copying
|
||||
|
|
@ -1927,6 +1961,7 @@ void free_fficall_data(void *ignored, void *p)
|
|||
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),
|
||||
|
|
@ -2060,7 +2095,7 @@ void free_cl_cif_args(void *ignored, void *p)
|
|||
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]"
|
||||
"cl_cif_args" "argv[0]" "argv[1]" "argv[2]"
|
||||
"((argc > 4) && SCHEME_TRUEP(argv[4]))"]
|
||||
@@@IFDEF{MZ_PRECISE_GC}{
|
||||
{
|
||||
|
|
@ -2082,6 +2117,51 @@ void free_cl_cif_args(void *ignored, void *p)
|
|||
|
||||
/*****************************************************************************/
|
||||
|
||||
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)))))])
|
||||
@string-append{
|
||||
if (SCHEME_SYMBOLP(v) && !SCHEME_SYM_WEIRDP(v)) {
|
||||
@(string-join
|
||||
(for/list ([e errnos])
|
||||
@string-append{
|
||||
if (!strcmp("@symbol->string[e]", SCHEME_SYM_VAL(v)))
|
||||
return scheme_make_integer(@symbol->string[e]);
|
||||
})
|
||||
"\n")
|
||||
}
|
||||
scheme_wrong_type(MYNAME, "@syms",0, argc, argv);
|
||||
return NULL;
|
||||
})
|
||||
}
|
||||
|
||||
/*****************************************************************************/
|
||||
|
||||
void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
|
||||
{
|
||||
char *str;
|
||||
|
|
|
|||
|
|
@ -1108,6 +1108,8 @@ typedef struct Scheme_Thread {
|
|||
Scheme_Object *mbox_last;
|
||||
Scheme_Object *mbox_sema;
|
||||
|
||||
long saved_errno;
|
||||
|
||||
#ifdef MZ_PRECISE_GC
|
||||
struct GC_Thread_Info *gc_info; /* managed by the GC */
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -13,12 +13,12 @@
|
|||
consistently.)
|
||||
*/
|
||||
|
||||
#define MZSCHEME_VERSION "4.2.3.4"
|
||||
#define MZSCHEME_VERSION "4.2.3.5"
|
||||
|
||||
#define MZSCHEME_VERSION_X 4
|
||||
#define MZSCHEME_VERSION_Y 2
|
||||
#define MZSCHEME_VERSION_Z 3
|
||||
#define MZSCHEME_VERSION_W 4
|
||||
#define MZSCHEME_VERSION_W 5
|
||||
|
||||
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
|
||||
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user