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

revert argument change in #%foreign exports

Browse Source 
The changed functions are documented and turn out to be used by the
`gui` package.
This commit is contained in:
Matthew Flatt 2020-12-20 16:23:39 -07:00
parent c006fa902f
commit 763c5465f6
8 changed files with 101 additions and 89 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.16")
(define version "7.9.0.17")
(define deps `("racket-lib"
["racket" #:version ,version]))

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

@ -44,10 +44,11 @@ cstructs, and another ctype for user-defined ctypes.}
@defproc[(ffi-call [ptr cpointer?] [in-types (listof ctype?)] [out-type ctype?]
[abi (or/c #f 'default 'stdcall 'sysv) #f]
[save-errno? any/c]
[orig-place? any/c]
[save-errno? any/c #f]
[orig-place? any/c #f]
[lock-name (or/c #f string?) #f]
[blocking? any/c #f])
[blocking? any/c #f]
[varargs-after (or/c #f positive-exact-integer?) #f])
procedure?]{
The primitive mechanism that creates Racket @tech{callout} values for
@ -57,10 +58,11 @@ values are marshaled.}
@defproc[(ffi-call-maker [in-types (listof ctype?)] [out-type ctype?]
[abi (or/c #f 'default 'stdcall 'sysv) #f]
[save-errno? any/c]
[orig-place? any/c]
[save-errno? any/c #f]
[orig-place? any/c #f]
[lock-name (or/c #f string?) #f]
[blocking? any/c #f])
[blocking? any/c #f]
[varargs-after (or/c #f positive-exact-integer?) #f])
(cpointer . -> . procedure?)]{
A curried variant of @racket[ffi-call] that takes the foreign-procedure pointer
@ -70,7 +72,8 @@ separately.}
@defproc[(ffi-callback [proc procedure?] [in-types any/c] [out-type any/c]
[abi (or/c #f 'default 'stdcall 'sysv) #f]
[atomic? any/c #f]
[async-apply (or/c #f ((-> any) . -> . any)) #f])
[async-apply (or/c #f ((-> any) . -> . any) box?) #f]
[varargs-after (or/c #f positive-exact-integer?) #f])
ffi-callback?]{
The symmetric counterpart of @racket[ffi-call]. It receives a Racket
@ -80,7 +83,8 @@ C pointer.}
@defproc[(ffi-callback-maker [in-types any/c] [out-type any/c]
[abi (or/c #f 'default 'stdcall 'sysv) #f]
[atomic? any/c #f]
[async-apply (or/c #f ((-> any) . -> . any)) #f])
[async-apply (or/c #f ((-> any) . -> . any) box?) #f]
[varargs-after (or/c #f positive-exact-integer?) #f])
(procedure? . -> . ffi-callback?)]{
A curried variant of @racket[ffi-callback] that takes the callback procedure

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

@ -534,8 +534,8 @@
;; for internal use
(define held-callbacks (make-weak-hasheq))
(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 make-ffi-callback (delay/cas (ffi-callback-maker itypes otype abi atomic? async-apply varargs-after)))
(define make-ffi-call (delay/cas (ffi-call-maker itypes otype abi errno orig-place? lock-name blocking? varargs-after)))
(define-syntax-rule (make-it wrap)
(make-ctype _fpointer
(lambda (x)

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

@ -3910,36 +3910,38 @@ 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(5)]))
if (SCHEME_FALSEP(argv[ARGPOS(4)]))
save_errno = 0;
else if (SCHEME_SYMBOLP(argv[ARGPOS(5)])
&& !SCHEME_SYM_WEIRDP(argv[ARGPOS(5)])) {
if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(5)]), "posix"))
else if (SCHEME_SYMBOLP(argv[ARGPOS(4)])
&& !SCHEME_SYM_WEIRDP(argv[ARGPOS(4)])) {
if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "posix"))
save_errno = 1;
else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(5)]), "windows"))
else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "windows"))
save_errno = 2;
}
if (save_errno == -1) {
scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(5), argc, argv);
scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(4), argc, argv);
}
} else
save_errno = 0;
# if defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL)
if (argc > ARGPOS(6)) orig_place = SCHEME_TRUEP(argv[ARGPOS(6)]);
if (argc > ARGPOS(5)) orig_place = SCHEME_TRUEP(argv[ARGPOS(5)]);
else orig_place = 0;
# endif /* defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL) */
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 (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)]));
}
}
/* ARGPOS(7) is `blocking?`, but we don't use that */
if (argc > ARGPOS(8)) {
varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(8), nargs);
} else
varargs_after = -1;
if (cp && SCHEME_FFIOBJP(cp))
name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name);
else
@ -4347,16 +4349,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));
if (argc > ARGPOS(4))
varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(4), nargs);
is_atomic = ((argc > ARGPOS(4)) && SCHEME_TRUEP(argv[ARGPOS(4)]));
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))
varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(6), nargs);
else
varargs_after = -1;
is_atomic = ((argc > ARGPOS(5)) && SCHEME_TRUEP(argv[ARGPOS(5)]));
sync = (is_atomic ? scheme_true : NULL);
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 */
@ -4402,6 +4404,7 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc
do_callback = ffi_queue_callback;
} else
do_callback = ffi_do_callback;
/* malloc space for everything needed, so a single free gets rid of this */
cl_cif_args = scheme_malloc_code(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*));
scheme_thread_code_start_write();

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

@ -3077,36 +3077,38 @@ 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(5)]))
if (SCHEME_FALSEP(argv[ARGPOS(4)]))
save_errno = 0;
else if (SCHEME_SYMBOLP(argv[ARGPOS(5)])
&& !SCHEME_SYM_WEIRDP(argv[ARGPOS(5)])) {
if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(5)]), "posix"))
else if (SCHEME_SYMBOLP(argv[ARGPOS(4)])
&& !SCHEME_SYM_WEIRDP(argv[ARGPOS(4)])) {
if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "posix"))
save_errno = 1;
else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(5)]), "windows"))
else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "windows"))
save_errno = 2;
}
if (save_errno == -1) {
scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(5), argc, argv);
scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(4), argc, argv);
}
} else
save_errno = 0;
@@IF{defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL)}{
if (argc > ARGPOS(6)) orig_place = SCHEME_TRUEP(argv[ARGPOS(6)]);
if (argc > ARGPOS(5)) orig_place = SCHEME_TRUEP(argv[ARGPOS(5)]);
else orig_place = 0;
}
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 (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)]));
}
}
/* ARGPOS(7) is `blocking?`, but we don't use that */
if (argc > ARGPOS(8)) {
varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(8), nargs);
} else
varargs_after = -1;
if (cp && SCHEME_FFIOBJP(cp))
name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name);
else
@ -3504,16 +3506,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));
if (argc > ARGPOS(4))
varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(4), nargs);
is_atomic = ((argc > ARGPOS(4)) && SCHEME_TRUEP(argv[ARGPOS(4)]));
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))
varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(6), nargs);
else
varargs_after = -1;
is_atomic = ((argc > ARGPOS(5)) && SCHEME_TRUEP(argv[ARGPOS(5)]));
sync = (is_atomic ? scheme_true : NULL);
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 */
@ -3559,6 +3561,7 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc
do_callback = ffi_queue_callback;
} else
do_callback = ffi_do_callback;
/* malloc space for everything needed, so a single free gets rid of this */
cl_cif_args = scheme_malloc_code(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*));
scheme_thread_code_start_write();

4
racket/src/cs/compile-file.ss
View File

@ -108,7 +108,7 @@
(when xpatch-path
(load xpatch-path))
(time
(define (compile-it)
(cond
[whole-program?
(unless (= 1 (length deps))
@ -150,4 +150,6 @@
;; Normal mode
(compile-file src dest)]))]))
(time (compile-it))
(printf " ~a bytes peak memory use\n" (maximum-memory-bytes))

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

@ -1517,15 +1517,15 @@
(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 #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?)
[(p in-types out-type abi save-errno)
(ffi-call p in-types out-type abi save-errno #f #f)]
[(p in-types out-type abi save-errno orig-place?)
(ffi-call p in-types out-type abi save-errno orig-place? #f #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 #f)]
[(p in-types out-type abi save-errno orig-place? lock-name blocking?)
(ffi-call p in-types out-type abi save-errno orig-place? lock-name blocking? #f)]
[(p in-types out-type abi save-errno orig-place? lock-name blocking? varargs-after)
(check who cpointer? 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)]))
@ -1536,15 +1536,15 @@
(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 #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?)
[(in-types out-type abi save-errno)
(ffi-call-maker in-types out-type abi save-errno #f #f)]
[(in-types out-type abi save-errno orig-place?)
(ffi-call-maker in-types out-type abi save-errno orig-place? #f #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 #f)]
[(in-types out-type abi save-errno orig-place? lock-name blocking?)
(ffi-call-maker in-types out-type abi save-errno orig-place? lock-name blocking? #f)]
[(in-types out-type abi save-errno orig-place? lock-name blocking? varargs-after)
(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)]))
@ -1940,11 +1940,11 @@
(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 #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)
[(proc in-types out-type abi atomic?)
(ffi-callback proc in-types out-type abi atomic? #f #f)]
[(proc in-types out-type abi atomic? async-apply)
(ffi-callback proc in-types out-type abi atomic? #f)]
[(proc in-types out-type abi atomic? async-apply varargs-after)
(check who procedure? 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)]))
@ -1955,11 +1955,11 @@
(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 #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)
[(in-types out-type abi atomic?)
(ffi-callback-maker in-types out-type abi atomic? #f #f)]
[(in-types out-type abi atomic? async-apply)
(ffi-callback-maker in-types out-type abi atomic? async-apply #f)]
[(in-types out-type abi atomic? async-apply varargs-after)
(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)]))

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 16
#define MZSCHEME_VERSION_W 17
/* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x