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

ffi/unsafe: add #:varargs-after to function-type options

Browse Source 
Needed on ARM Mac OS to call a function like `fcntl`.
This commit is contained in:
Matthew Flatt 2020-12-20 13:00:11 -07:00
parent 6033237ed6
commit c006fa902f
9 changed files with 349 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -14,7 +14,7 @@
;; In the Racket source repo, this version should change only when
;; "racket_version.h" changes:
(define version "7.9.0.15")
(define version "7.9.0.16")
(define deps `("racket-lib"
["racket" #:version ,version]))

20
pkgs/racket-doc/scribblings/foreign/types.scrbl
View File

@ -517,6 +517,7 @@ the later case, the result is the @racket[ctype]).}
@defproc[(_cprocedure [input-types (list ctype?)]
[output-type ctype?]
[#:abi abi (or/c #f 'default 'stdcall 'sysv) #f]
[#:varargs-after varargs-after (or/c #f positive-exact-integer?) #f]
[#:atomic? atomic? any/c #f]
[#:async-apply async-apply (or/c #f ((-> any/c) . -> . any/c) box?) #f]
[#:lock-name lock-name (or/c string? #f) #f]
@ -554,6 +555,17 @@ values---@racket['stdcall] and @racket['sysv] (i.e., ``cdecl'')---are
currently supported only for 32-bit Windows; using them on other
platforms raises an exception. See also @racketmodname[ffi/winapi].
The optional @racket[varargs-after] argument indicates whether some
function-type arguments should be considered ``varargs,'' which are
argument represented by an ellipsis @litchar{...} in the C
declaration. A @racket[#f] value indicates that the C function type
does not have varargs. If @racket[varargs-after] is a number, then
arguments after the first @racket[varargs-after] arguments are
varargs. Note that @racket[#f] is different from @racket[(length
input-types)] on some platforms; the possibility of varargs for a
function may imply a different calling convention even for non-vararg
arguments.
For @tech{callouts} to foreign functions with the generated type:
@itemize[
@ -759,12 +771,14 @@ For @tech{callbacks} to Racket functions with the generated type:
]
@history[#:changed "6.3" @elem{Added the @racket[#:lock-name] argument.}
#:changed "6.12.0.2" @elem{Added the @racket[#:blocking?] argument.}]}
#:changed "6.12.0.2" @elem{Added the @racket[#:blocking?] argument.}
#:changed "7.9.0.16" @elem{Added the @racket[#:varargs-after] argument.}]}
@defform/subs[#:literals (->> :: :)
(_fun fun-option ... maybe-args type-spec ... ->> type-spec
maybe-wrapper)
([fun-option (code:line #:abi abi-expr)
(code:line #:varargs-after varargs-after-expr)
(code:line #:save-errno save-errno-expr)
(code:line #:keep keep-expr)
(code:line #:atomic? atomic?-expr)
@ -798,6 +812,7 @@ specifies a function that receives a string and an integer
and returns an integer.
See @racket[_cprocedure] for information about the @racket[#:abi],
@racket[#:varargs-after],
@racket[#:save-errno], @racket[#:keep], @racket[#:atomic?],
@racket[#:async-apply], @racket[#:in-original-place?], and
@racket[#:blocking] options.
@ -893,7 +908,8 @@ specifications:
@history[#:changed "6.2" @elem{Added the @racket[#:retry] option.}
#:changed "6.3" @elem{Added the @racket[#:lock-name] option.}
#:changed "6.12.0.2" @elem{Added the @racket[#:blocking?] option.}]}
#:changed "6.12.0.2" @elem{Added the @racket[#:blocking?] option.}
#:changed "7.9.0.16" @elem{Added the @racket[#:varargs-after] option.}]}
@defproc[(function-ptr [ptr-or-proc (or cpointer? procedure?)]
[fun-type ctype?])

39
pkgs/racket-test-core/tests/racket/foreign-test.c
View File

@ -1,4 +1,5 @@
#include <stdlib.h>
#include <stdarg.h>
#include <errno.h>
#ifdef USE_THREAD_TEST
#include <pthread.h>
@ -337,3 +338,41 @@ X int sum_after_callback(int *a, int n, void (*cb)()) {
return s;
}
typedef int (*varargs_callback)(int, int, ...);
X long varargs_check(int init, int n, ...) {
va_list va;
long accum = init;
va_start(va, n);
while (n-- > 0) {
int kind = va_arg(va, int);
switch (kind) {
case 1:
accum += va_arg(va, int);
break;
case 2:
accum += va_arg(va, long);
break;
case 3:
accum += va_arg(va, double);
break;
case 4:
accum += *(va_arg(va, int*));
break;
case 5:
accum += (va_arg(va, varargs_callback))(1, 2, 3.0);
break;
default:
accum = -1;
n = 0;
break;
}
}
va_end(va);
return accum;
}

37
pkgs/racket-test-core/tests/racket/foreign-test.rktl
View File

@ -680,6 +680,43 @@
(for ([i (in-range N)])
(ptr-set! m _int i 0)))))))))
(let ()
(define-syntax (_varargs stx)
(syntax-case stx ()
[(_ arg ...)
#`(_fun #:varargs-after 2
_int ; init for result
(_int = #,(quotient (length (syntax->list #'(arg ...))) 2))
;; each argument is an _int in [1, 5] followed by:
;; 1 - _int
;; 2 - _long
;; 3 - _double
;; 4 - _int pointer
;; 5 - (_fun #:varargs-after 2 _int _long ... -> _int)
arg ... -> _long)]))
(test 77
(get-ffi-obj 'varargs_check test-lib (_varargs))
77)
(test 75
(get-ffi-obj 'varargs_check test-lib (_varargs (_int = 1) _int))
77 -2)
(test 277
(get-ffi-obj 'varargs_check test-lib (_varargs (_int = 2) _long))
77 200)
(test 86
(get-ffi-obj 'varargs_check test-lib (_varargs (_int = 3) _double))
76 10.2)
(test 96
(get-ffi-obj 'varargs_check test-lib (_varargs (_int = 3) _double (_int = 1) _int (_int = 2) _long (_int = 3) _double))
86 1.0 2 3 4.0)
(test 67
(get-ffi-obj 'varargs_check test-lib (_varargs (_int = 4) (_ptr i _int) (_int = 1) _int))
50 8 9)
(test 16
(get-ffi-obj 'varargs_check test-lib (_varargs (_int = 5) (_fun #:varargs-after 2 _int _long _double -> _int)))
10 (lambda (a b c) (inexact->exact (+ a b c))))
(void))
(let ()
(struct foo (ptr)
#:property prop:cpointer 0)

12
racket/collects/ffi/unsafe.rkt
View File

@ -503,6 +503,7 @@
;; (callouts) or the input procedure (callbacks).
(define* (_cprocedure itypes otype
#:abi [abi #f]
#:varargs-after [varargs-after #f]
#:wrapper [wrapper #f]
#:keep [keep #t]
#:atomic? [atomic? #f]
@ -511,7 +512,7 @@
#:lock-name [lock-name #f]
#:async-apply [async-apply #f]
#:save-errno [errno #f])
(_cprocedure* itypes otype abi wrapper keep atomic? orig-place? blocking? async-apply errno lock-name))
(_cprocedure* itypes otype abi varargs-after wrapper keep atomic? orig-place? blocking? async-apply errno lock-name))
;; A lightwegith delay meachnism for a single-argument function when
;; it's ok (but unlikely) to evaluate `expr` more than once and keep
@ -532,9 +533,9 @@
;; for internal use
(define held-callbacks (make-weak-hasheq))
(define (_cprocedure* itypes otype abi wrapper keep atomic? orig-place? blocking? async-apply errno lock-name)
(define make-ffi-callback (delay/cas (ffi-callback-maker itypes otype abi atomic? async-apply)))
(define make-ffi-call (delay/cas (ffi-call-maker itypes otype abi errno orig-place? lock-name blocking?)))
(define (_cprocedure* itypes otype abi varargs-after wrapper keep atomic? orig-place? blocking? async-apply errno lock-name)
(define make-ffi-callback (delay/cas (ffi-callback-maker itypes otype abi varargs-after atomic? async-apply)))
(define make-ffi-call (delay/cas (ffi-call-maker itypes otype abi varargs-after errno orig-place? lock-name blocking?)))
(define-syntax-rule (make-it wrap)
(make-ctype _fpointer
(lambda (x)
@ -570,7 +571,7 @@
(provide _fun)
(define-for-syntax _fun-keywords
`([#:abi ,#'#f] [#:keep ,#'#t] [#:atomic? ,#'#f]
`([#:abi ,#'#f] [#:varargs-after ,#'#f] [#:keep ,#'#t] [#:atomic? ,#'#f]
[#:in-original-place? ,#'#f] [#:blocking? ,#'#f] [#:lock-name ,#'#f]
[#:async-apply ,#'#f] [#:save-errno ,#'#f]
[#:retry #f]))
@ -730,6 +731,7 @@
#`(_cprocedure* (list #,@(filter-map car inputs))
#,(car output)
#,(kwd-ref '#:abi)
#,(kwd-ref '#:varargs-after)
#,wrapper
#,(kwd-ref '#:keep)
#,(kwd-ref '#:atomic?)

106
racket/src/bc/foreign/foreign.c
View File

@ -3461,6 +3461,33 @@ static void release_ffi_lock(void *lock)
# endif /* MZ_USE_PLACES */
}
/*****************************************************************************/
static int extract_varargs_after(const char *who, int argc, Scheme_Object **argv, int argpos, int nargs)
{
int varargs_after;
if (SCHEME_FALSEP(argv[argpos]))
varargs_after = -1;
else if (SCHEME_INTP(argv[argpos])
&& (SCHEME_INT_VAL(argv[argpos]) > 0)) {
varargs_after = SCHEME_INT_VAL(argv[argpos]);
} else if (SCHEME_BIGNUMP(argv[argpos])
&& SCHEME_BIGPOS((argv[argpos]))) {
varargs_after = nargs + 1;
} else {
varargs_after = -1;
scheme_wrong_contract(who, "(or/c exact-positive-integer? #f)", argpos, argc, argv);
}
if (varargs_after > nargs)
scheme_contract_error(who, "varargs-after value is too large",
"given value", 1, argv[argpos],
"argument count", 1, scheme_make_integer(nargs),
NULL);
return varargs_after;
}
/*****************************************************************************/
/* Calling foreign function objects */
@ -3848,6 +3875,7 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
Scheme_Object *otype = argv[ARGPOS(2)];
Scheme_Object *obj, *data, *p, *base, *cp, *name, *a[1];
ffi_abi abi;
int varargs_after;
intptr_t ooff;
GC_CAN_IGNORE ffi_type *rtype, **atypes;
GC_CAN_IGNORE ffi_cif *cif;
@ -3882,30 +3910,34 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
rtype = CTYPE_ARG_PRIMTYPE(base);
abi = GET_ABI(who, ARGPOS(3));
if (argc > ARGPOS(4)) {
varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(4), nargs);
} else
varargs_after = -1;
if (argc > ARGPOS(5)) {
save_errno = -1;
if (SCHEME_FALSEP(argv[ARGPOS(4)]))
if (SCHEME_FALSEP(argv[ARGPOS(5)]))
save_errno = 0;
else if (SCHEME_SYMBOLP(argv[ARGPOS(4)])
&& !SCHEME_SYM_WEIRDP(argv[ARGPOS(4)])) {
if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "posix"))
else if (SCHEME_SYMBOLP(argv[ARGPOS(5)])
&& !SCHEME_SYM_WEIRDP(argv[ARGPOS(5)])) {
if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(5)]), "posix"))
save_errno = 1;
else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "windows"))
else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(5)]), "windows"))
save_errno = 2;
}
if (save_errno == -1) {
scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(4), argc, argv);
scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(5), argc, argv);
}
} else
save_errno = 0;
# if defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL)
if (argc > ARGPOS(5)) orig_place = SCHEME_TRUEP(argv[ARGPOS(5)]);
if (argc > ARGPOS(6)) orig_place = SCHEME_TRUEP(argv[ARGPOS(6)]);
else orig_place = 0;
# endif /* defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL) */
if (argc > ARGPOS(6)) {
if (!SCHEME_FALSEP(argv[ARGPOS(6)])) {
if (!SCHEME_CHAR_STRINGP(argv[ARGPOS(6)]))
scheme_wrong_contract(who, "(or/c string? #f)", ARGPOS(6), argc, argv);
lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[ARGPOS(6)]));
if (argc > ARGPOS(7)) {
if (!SCHEME_FALSEP(argv[ARGPOS(7)])) {
if (!SCHEME_CHAR_STRINGP(argv[ARGPOS(7)]))
scheme_wrong_contract(who, "(or/c string? #f)", ARGPOS(7), argc, argv);
lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[ARGPOS(7)]));
}
}
if (cp && SCHEME_FFIOBJP(cp))
@ -3921,8 +3953,13 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
atypes[i] = CTYPE_ARG_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");
if (varargs_after == -1) {
if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
} else {
if (ffi_prep_cif_var(cif, abi, varargs_after, nargs, rtype, atypes) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif_var did not return FFI_OK");
}
data = scheme_make_vector(FFI_CALL_VEC_SIZE, NULL);
SCHEME_VEC_ELS(data)[0] = name;
SCHEME_VEC_ELS(data)[1] = obj;
@ -3954,7 +3991,7 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
#undef ARGPOS
}
/* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place? lock-name blocking?]) -> (in-types -> out-value) */
/* (ffi-call ffi-obj in-types out-type [abi varargs-after save-errno? orig-place? lock-name blocking?]) -> (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[])
@ -3963,7 +4000,7 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
}
#undef MYNAME
/* (ffi-call-maker in-types out-type [abi save-errno? orig-place? lock-name blocking?]) -> (ffi->obj -> (in-types -> out-value)) */
/* (ffi-call-maker in-types out-type [abi varargs-after save-errno? orig-place? lock-name blocking?]) -> (ffi->obj -> (in-types -> out-value)) */
/* Curried version of `ffi-call` */
#define MYNAME "ffi-call-maker"
static Scheme_Object *foreign_ffi_call_maker(int argc, Scheme_Object *argv[])
@ -4257,7 +4294,7 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc
Scheme_Object *p, *base;
ffi_abi abi;
int is_atomic;
int nargs, i;
int nargs, i, varargs_after;
ffi_status ffi_ok;
/* 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
@ -4310,12 +4347,16 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc
scheme_wrong_contract(who, "ctype?", ARGPOS(2), argc, argv);
rtype = CTYPE_ARG_PRIMTYPE(base);
abi = GET_ABI(who, ARGPOS(3));
is_atomic = ((argc > ARGPOS(4)) && SCHEME_TRUEP(argv[ARGPOS(4)]));
if (argc > ARGPOS(4))
varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(4), nargs);
else
varargs_after = -1;
is_atomic = ((argc > ARGPOS(5)) && SCHEME_TRUEP(argv[ARGPOS(5)]));
sync = (is_atomic ? scheme_true : NULL);
if ((argc > ARGPOS(5))
&& !SCHEME_BOXP(argv[ARGPOS(5)])
&& !scheme_check_proc_arity2(NULL, 1, ARGPOS(5), argc, argv, 1))
scheme_wrong_contract(who, "(or/c #f (procedure-arity-includes/c 0) box?)", ARGPOS(5), argc, argv);
if ((argc > ARGPOS(6))
&& !SCHEME_BOXP(argv[ARGPOS(6)])
&& !scheme_check_proc_arity2(NULL, 1, ARGPOS(6), argc, argv, 1))
scheme_wrong_contract(who, "(or/c #f (procedure-arity-includes/c 0) box?)", ARGPOS(6), argc, argv);
if (curry) {
/* all checks are done */
@ -4378,8 +4419,13 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc
}
atypes[i] = CTYPE_ARG_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");
if (varargs_after == -1) {
if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
} else {
if (ffi_prep_cif_var(cif, abi, varargs_after, nargs, rtype, atypes) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif_var did not return FFI_OK");
}
scheme_thread_code_end_write();
data = (ffi_callback_struct*)scheme_malloc_tagged(sizeof(ffi_callback_struct));
data->so.type = ffi_callback_tag;
@ -5123,13 +5169,13 @@ void scheme_init_foreign(Scheme_Startup_Env *env)
scheme_addto_prim_instance("make-sized-byte-string",
scheme_make_noncm_prim(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), env);
scheme_addto_prim_instance("ffi-call",
scheme_make_noncm_prim(foreign_ffi_call, "ffi-call", 3, 8), env);
scheme_make_noncm_prim(foreign_ffi_call, "ffi-call", 3, 9), env);
scheme_addto_prim_instance("ffi-call-maker",
scheme_make_noncm_prim(foreign_ffi_call_maker, "ffi-call-maker", 2, 7), env);
scheme_make_noncm_prim(foreign_ffi_call_maker, "ffi-call-maker", 2, 8), env);
scheme_addto_prim_instance("ffi-callback",
scheme_make_noncm_prim(foreign_ffi_callback, "ffi-callback", 3, 6), env);
scheme_addto_prim_instance("ffi-callback-maker",
scheme_make_noncm_prim(foreign_ffi_callback_maker, "ffi-callback-maker", 2, 5), env);
scheme_make_noncm_prim(foreign_ffi_callback_maker, "ffi-callback-maker", 2, 6), env);
scheme_addto_prim_instance("saved-errno",
scheme_make_immed_prim(foreign_saved_errno, "saved-errno", 0, 1), env);
scheme_addto_prim_instance("lookup-errno",
@ -5490,13 +5536,13 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_addto_primitive_instance("make-sized-byte-string",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-sized-byte-string", 2, 2), env);
scheme_addto_primitive_instance("ffi-call",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call", 3, 8), env);
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call", 3, 9), env);
scheme_addto_primitive_instance("ffi-call-maker",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call-maker", 2, 7), env);
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call-maker", 2, 8), env);
scheme_addto_primitive_instance("ffi-callback",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-callback", 3, 6), env);
scheme_addto_primitive_instance("ffi-callback-maker",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-callback-maker", 2, 5), env);
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-callback-maker", 2, 6), env);
scheme_addto_primitive_instance("saved-errno",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "saved-errno", 0, 1), env);
scheme_addto_primitive_instance("lookup-errno",

100
racket/src/bc/foreign/foreign.rktc
View File

@ -2628,6 +2628,33 @@ static void release_ffi_lock(void *lock)
}
}
/*****************************************************************************/
static int extract_varargs_after(const char *who, int argc, Scheme_Object **argv, int argpos, int nargs)
{
int varargs_after;
if (SCHEME_FALSEP(argv[argpos]))
varargs_after = -1;
else if (SCHEME_INTP(argv[argpos])
&& (SCHEME_INT_VAL(argv[argpos]) > 0)) {
varargs_after = SCHEME_INT_VAL(argv[argpos]);
} else if (SCHEME_BIGNUMP(argv[argpos])
&& SCHEME_BIGPOS((argv[argpos]))) {
varargs_after = nargs + 1;
} else {
varargs_after = -1;
scheme_wrong_contract(who, "(or/c exact-positive-integer? #f)", argpos, argc, argv);
}
if (varargs_after > nargs)
scheme_contract_error(who, "varargs-after value is too large",
"given value", 1, argv[argpos],
"argument count", 1, scheme_make_integer(nargs),
NULL);
return varargs_after;
}
/*****************************************************************************/
/* Calling foreign function objects */
@ -3015,6 +3042,7 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
Scheme_Object *otype = argv[ARGPOS(2)];
Scheme_Object *obj, *data, *p, *base, *cp, *name, *a[1];
ffi_abi abi;
int varargs_after;
intptr_t ooff;
GC_CAN_IGNORE ffi_type *rtype, **atypes;
GC_CAN_IGNORE ffi_cif *cif;
@ -3049,30 +3077,34 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
rtype = CTYPE_ARG_PRIMTYPE(base);
abi = GET_ABI(who, ARGPOS(3));
if (argc > ARGPOS(4)) {
varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(4), nargs);
} else
varargs_after = -1;
if (argc > ARGPOS(5)) {
save_errno = -1;
if (SCHEME_FALSEP(argv[ARGPOS(4)]))
if (SCHEME_FALSEP(argv[ARGPOS(5)]))
save_errno = 0;
else if (SCHEME_SYMBOLP(argv[ARGPOS(4)])
&& !SCHEME_SYM_WEIRDP(argv[ARGPOS(4)])) {
if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "posix"))
else if (SCHEME_SYMBOLP(argv[ARGPOS(5)])
&& !SCHEME_SYM_WEIRDP(argv[ARGPOS(5)])) {
if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(5)]), "posix"))
save_errno = 1;
else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "windows"))
else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(5)]), "windows"))
save_errno = 2;
}
if (save_errno == -1) {
scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(4), argc, argv);
scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(5), argc, argv);
}
} else
save_errno = 0;
@@IF{defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL)}{
if (argc > ARGPOS(5)) orig_place = SCHEME_TRUEP(argv[ARGPOS(5)]);
if (argc > ARGPOS(6)) orig_place = SCHEME_TRUEP(argv[ARGPOS(6)]);
else orig_place = 0;
}
if (argc > ARGPOS(6)) {
if (!SCHEME_FALSEP(argv[ARGPOS(6)])) {
if (!SCHEME_CHAR_STRINGP(argv[ARGPOS(6)]))
scheme_wrong_contract(who, "(or/c string? #f)", ARGPOS(6), argc, argv);
lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[ARGPOS(6)]));
if (argc > ARGPOS(7)) {
if (!SCHEME_FALSEP(argv[ARGPOS(7)])) {
if (!SCHEME_CHAR_STRINGP(argv[ARGPOS(7)]))
scheme_wrong_contract(who, "(or/c string? #f)", ARGPOS(7), argc, argv);
lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[ARGPOS(7)]));
}
}
if (cp && SCHEME_FFIOBJP(cp))
@ -3088,8 +3120,13 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
atypes[i] = CTYPE_ARG_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");
if (varargs_after == -1) {
if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
} else {
if (ffi_prep_cif_var(cif, abi, varargs_after, nargs, rtype, atypes) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif_var did not return FFI_OK");
}
data = scheme_make_vector(FFI_CALL_VEC_SIZE, NULL);
SCHEME_VEC_ELS(data)[0] = name;
SCHEME_VEC_ELS(data)[1] = obj;
@ -3121,15 +3158,15 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
#undef ARGPOS
}
/* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place? lock-name blocking?]) -> (in-types -> out-value) */
/* (ffi-call ffi-obj in-types out-type [abi varargs-after save-errno? orig-place? lock-name blocking?]) -> (in-types -> out-value) */
/* the real work is done by ffi_do_call above */
@cdefine[ffi-call 3 8]{
@cdefine[ffi-call 3 9]{
return ffi_call_or_curry(MYNAME, 0, argc, argv);
}
/* (ffi-call-maker in-types out-type [abi save-errno? orig-place? lock-name blocking?]) -> (ffi->obj -> (in-types -> out-value)) */
/* (ffi-call-maker in-types out-type [abi varargs-after save-errno? orig-place? lock-name blocking?]) -> (ffi->obj -> (in-types -> out-value)) */
/* Curried version of `ffi-call` */
@cdefine[ffi-call-maker 2 7]{
@cdefine[ffi-call-maker 2 8]{
return ffi_call_or_curry(MYNAME, 1, argc, argv);
}
@ -3414,7 +3451,7 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc
Scheme_Object *p, *base;
ffi_abi abi;
int is_atomic;
int nargs, i;
int nargs, i, varargs_after;
ffi_status ffi_ok;
/* 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
@ -3467,12 +3504,16 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc
scheme_wrong_contract(who, "ctype?", ARGPOS(2), argc, argv);
rtype = CTYPE_ARG_PRIMTYPE(base);
abi = GET_ABI(who, ARGPOS(3));
is_atomic = ((argc > ARGPOS(4)) && SCHEME_TRUEP(argv[ARGPOS(4)]));
if (argc > ARGPOS(4))
varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(4), nargs);
else
varargs_after = -1;
is_atomic = ((argc > ARGPOS(5)) && SCHEME_TRUEP(argv[ARGPOS(5)]));
sync = (is_atomic ? scheme_true : NULL);
if ((argc > ARGPOS(5))
&& !SCHEME_BOXP(argv[ARGPOS(5)])
&& !scheme_check_proc_arity2(NULL, 1, ARGPOS(5), argc, argv, 1))
scheme_wrong_contract(who, "(or/c #f (procedure-arity-includes/c 0) box?)", ARGPOS(5), argc, argv);
if ((argc > ARGPOS(6))
&& !SCHEME_BOXP(argv[ARGPOS(6)])
&& !scheme_check_proc_arity2(NULL, 1, ARGPOS(6), argc, argv, 1))
scheme_wrong_contract(who, "(or/c #f (procedure-arity-includes/c 0) box?)", ARGPOS(6), argc, argv);
if (curry) {
/* all checks are done */
@ -3535,8 +3576,13 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc
}
atypes[i] = CTYPE_ARG_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");
if (varargs_after == -1) {
if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
} else {
if (ffi_prep_cif_var(cif, abi, varargs_after, nargs, rtype, atypes) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif_var did not return FFI_OK");
}
scheme_thread_code_end_write();
@cmake["data" ffi-callback
"cl_cif_args" "(curry ? NULL : argv[ARGPOS(0)])" "argv[ARGPOS(1)]" "argv[ARGPOS(2)]"
@ -3615,7 +3661,7 @@ static Scheme_Object *make_ffi_callback_from_curried(int argc, Scheme_Object *ar
/* (ffi-callback-maker in-types out-type [abi atomic? sync]) -> (proc -> ffi-callback) */
/* Curried version of `ffi-callback`. Check arguments eagerly, but we don't do anything
otherwise until a function is available. */
@cdefine[ffi-callback-maker 2 5]{
@cdefine[ffi-callback-maker 2 6]{
int i;
Scheme_Object *vec, *a[1];

163
racket/src/cs/rumble/foreign.ss
View File

@ -1516,45 +1516,44 @@
[(p in-types out-type)
(ffi-call p in-types out-type #f #f #f)]
[(p in-types out-type abi)
(ffi-call p in-types out-type abi #f #f)]
[(p in-types out-type abi save-errno)
(ffi-call p in-types out-type abi save-errno #f)]
[(p in-types out-type abi save-errno orig-place?)
(ffi-call p in-types out-type abi save-errno orig-place? #f)]
[(p in-types out-type abi save-errno orig-place? lock-name)
(ffi-call p in-types out-type abi save-errno orig-place? lock-name #f)]
[(p in-types out-type abi save-errno orig-place? lock-name blocking?)
(ffi-call p in-types out-type abi #f #f #f)]
[(p in-types out-type abi varargs-after)
(ffi-call p in-types out-type abi varargs-after #f #f)]
[(p in-types out-type abi varargs-after save-errno)
(ffi-call p in-types out-type abi varargs-after save-errno #f)]
[(p in-types out-type abi varargs-after save-errno orig-place?)
(ffi-call p in-types out-type abi varargs-after save-errno orig-place? #f)]
[(p in-types out-type abi varargs-after save-errno orig-place? lock-name)
(ffi-call p in-types out-type abi varargs-after save-errno orig-place? lock-name #f)]
[(p in-types out-type abi varargs-after save-errno orig-place? lock-name blocking?)
(check who cpointer? p)
(check who (lambda (l)
(and (list? l)
(andmap ctype? l)))
:contract "(listof ctype?)"
in-types)
(check who ctype? out-type)
(check who string? :or-false lock-name)
((ffi-call/callable #t in-types out-type abi save-errno lock-name blocking? orig-place? #f #f) p)]))
(check-ffi-call who in-types out-type abi varargs-after save-errno lock-name)
((ffi-call/callable #t in-types out-type abi varargs-after save-errno lock-name blocking? orig-place? #f #f) p)]))
(define/who ffi-call-maker
(case-lambda
[(in-types out-type)
(ffi-call-maker in-types out-type #f #f #f)]
(ffi-call-maker in-types out-type #f #f #f #f)]
[(in-types out-type abi)
(ffi-call-maker in-types out-type abi #f #f)]
[(in-types out-type abi save-errno)
(ffi-call-maker in-types out-type abi save-errno #f)]
[(in-types out-type abi save-errno orig-place?)
(ffi-call-maker in-types out-type abi save-errno orig-place? #f)]
[(in-types out-type abi save-errno orig-place? lock-name)
(ffi-call-maker in-types out-type abi save-errno orig-place? lock-name #f)]
[(in-types out-type abi save-errno orig-place? lock-name blocking?)
(check who (lambda (l)
(and (list? l)
(andmap ctype? l)))
:contract "(listof ctype?)"
in-types)
(check who ctype? out-type)
(check who string? :or-false lock-name)
(ffi-call/callable #t in-types out-type abi save-errno lock-name blocking? orig-place? #f #f)]))
(ffi-call-maker in-types out-type abi #f #f #f)]
[(in-types out-type abi varargs-after)
(ffi-call-maker in-types out-type abi varargs-after #f #f)]
[(in-types out-type abi varargs-after save-errno)
(ffi-call-maker in-types out-type abi varargs-after save-errno #f)]
[(in-types out-type abi varargs-after save-errno orig-place?)
(ffi-call-maker in-types out-type abi varargs-after save-errno orig-place? #f)]
[(in-types out-type abi varargs-after save-errno orig-place? lock-name)
(ffi-call-maker in-types out-type abi varargs-after save-errno orig-place? lock-name #f)]
[(in-types out-type abi varargs-after save-errno orig-place? lock-name blocking?)
(check-ffi-call who in-types out-type abi varargs-after save-errno lock-name)
(ffi-call/callable #t in-types out-type abi varargs-after save-errno lock-name blocking? orig-place? #f #f)]))
(define (check-ffi-call who in-types out-type abi varargs-after save-errno lock-name)
(check-ffi who in-types out-type abi varargs-after)
(check who (lambda (save-errno) (#%memq save-errno '(#f posix windows)))
:contract "(or/c #f 'posix 'windows)"
save-errno)
(check who string? :or-false lock-name))
;; For sanity checking of callbacks during a blocking callout:
(define-virtual-register currently-blocking? #f)
@ -1569,11 +1568,14 @@
(define call-locks (make-eq-hashtable))
(define (ffi-call/callable call? in-types out-type abi save-errno lock-name blocking? orig-place? atomic? async-apply)
(let* ([conv (case abi
[(stdcall) '__stdcall]
[(sysv) '__cdecl]
[else #f])]
(define (ffi-call/callable call? in-types out-type abi varargs-after save-errno lock-name blocking? orig-place? atomic? async-apply)
(let* ([conv* (let ([conv* (case abi
[(stdcall) '(__stdcall)]
[(sysv) '(__cdecl)]
[else '()])])
(if varargs-after
(cons `(__varargs_after ,varargs-after) conv*)
conv*))]
[by-value? (lambda (type)
;; An 'array rep is compound, but should be
;; passed as a pointer, so only pass 'struct and
@ -1616,7 +1618,7 @@
(list
(lambda (to-wrap)
(,(if call? 'foreign-procedure 'foreign-callable)
,conv
,@conv*
,@(if (or blocking? async-apply) '(__collect_safe) '())
to-wrap
,(map (lambda (in-type id)
@ -1935,40 +1937,69 @@
(define/who ffi-callback
(case-lambda
[(proc in-types out-type)
(ffi-callback proc in-types out-type #f #f #f)]
(ffi-callback proc in-types out-type #f #f #f #f)]
[(proc in-types out-type abi)
(ffi-callback proc in-types out-type abi #f #f)]
[(proc in-types out-type abi atomic?)
(ffi-callback proc in-types out-type abi atomic? #f)]
[(proc in-types out-type abi atomic? async-apply)
(ffi-callback proc in-types out-type abi #f #f #f)]
[(proc in-types out-type abi varargs-after)
(ffi-callback proc in-types out-type abi varargs-after #f #f)]
[(proc in-types out-type abi varargs-after atomic?)
(ffi-callback proc in-types out-type abi varargs-after atomic? #f)]
[(proc in-types out-type abi varargs-after atomic? async-apply)
(check who procedure? proc)
(check who (lambda (l)
(and (list? l)
(andmap ctype? l)))
:contract "(listof ctype?)"
in-types)
(check who ctype? out-type)
((ffi-callback-maker in-types out-type abi atomic? async-apply) proc)]))
(check-ffi-callback who in-types out-type abi varargs-after async-apply)
((ffi-callback-maker* in-types out-type abi varargs-after atomic? async-apply) proc)]))
(define/who ffi-callback-maker
(case-lambda
[(in-types out-type)
(ffi-callback-maker in-types out-type #f #f #f)]
(ffi-callback-maker in-types out-type #f #f #f #f)]
[(in-types out-type abi)
(ffi-callback-maker in-types out-type abi #f #f)]
[(in-types out-type abi atomic?)
(ffi-callback-maker in-types out-type abi atomic? #f)]
[(in-types out-type abi atomic? async-apply)
(check who (lambda (l)
(and (list? l)
(andmap ctype? l)))
:contract "(listof ctype?)"
in-types)
(check who ctype? out-type)
(let ([make-code (ffi-call/callable #f in-types out-type abi #f #f #f #f (and atomic? #t) async-apply)])
(lambda (proc)
(check 'make-ffi-callback procedure? proc)
(create-callback (make-code proc))))]))
(ffi-callback-maker in-types out-type abi #f #f #f)]
[(in-types out-type abi varargs-after)
(ffi-callback-maker in-types out-type abi varargs-after #f #f)]
[(in-types out-type abi varargs-after atomic?)
(ffi-callback-maker in-types out-type abi varargs-after atomic? #f)]
[(in-types out-type abi varargs-after atomic? async-apply)
(check-ffi-callback who in-types out-type abi varargs-after async-apply)
(ffi-callback-maker* in-types out-type abi varargs-after atomic? async-apply)]))
(define (ffi-callback-maker* in-types out-type abi varargs-after atomic? async-apply)
(let ([make-code (ffi-call/callable #f in-types out-type abi varargs-after #f #f #f #f (and atomic? #t) async-apply)])
(lambda (proc)
(check 'make-ffi-callback procedure? proc)
(create-callback (make-code proc)))))
(define (check-ffi-callback who in-types out-type abi varargs-after async-apply)
(check-ffi who in-types out-type abi varargs-after)
(check who (lambda (async-apply)
(or (not async-apply)
(box? async-apply)
(and (procedure? async-apply)
(unsafe-procedure-and-arity-includes? async-apply 1))))
:contract "(or/c #f (procedure-arity-includes/c 1) box?)"
async-apply))
(define (check-ffi who in-types out-type abi varargs-after)
(check who (lambda (l)
(and (list? l)
(andmap ctype? l)))
:contract "(listof ctype?)"
in-types)
(check who ctype? out-type)
(check who (lambda (a) (#%memq a '(#f default stdcall sysv)))
:contract "(or/c #f 'default 'stdcall 'sysv)"
abi)
(check who (lambda (varargs-after) (or (not varargs-after)
(and (exact-positive-integer? varargs-after))))
:contract "(or/c #f exact-positive-integer?)"
varargs-after)
(when varargs-after
(let ([len (length in-types)])
(when (> varargs-after len)
(raise-arguments-error who
"varargs-after value is too large"
"given value" varargs-after
"argument count" len)))))
;; ----------------------------------------

2
racket/src/version/racket_version.h
View File

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 9
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 15
#define MZSCHEME_VERSION_W 16
/* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x