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

ffi/unsafe: new error message convention at primitives

Browse Source 
Also, fix FFI procedures to preserve names: change `ptr-ref' with
`_fpointer' on an `ffi-obj' value to return the `ffi-obj'
value, so that the name in the `ffi-obj' value can be used
by `_cprocedure'.

Closes PR 12645
This commit is contained in:
Matthew Flatt 2012-05-31 21:44:34 -07:00
parent c8380b94e5
commit 85a2267e6c
11 changed files with 592 additions and 482 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/scribblings/foreign/libs.scrbl
View File

@ -118,7 +118,7 @@ corresponding library.}
[failure-thunk (or/c (-> any) #f) #f])
any]{
Looks for the given object name @racket[objname] in the given
Looks for @racket[objname] in
@racket[lib] library. If @racket[lib] is not a @tech{foreign-library value}
it is converted to one by calling @racket[ffi-lib]. If @racket[objname]
is found in @racket[lib], it is
@ -129,9 +129,9 @@ is most often used with function types created with @racket[_fun].
Keep in mind that @racket[get-ffi-obj] is an unsafe procedure; see
@secref["intro"] for details.
If the object is not found, and @racket[failure-thunk] is provided, it is
If the name is not found, and @racket[failure-thunk] is provided, it is
used to produce a return value. For example, a failure thunk can be
provided to report a specific error if an object is not found:
provided to report a specific error if an name is not found:
@racketblock[
(define foo
@ -181,14 +181,15 @@ actual call.}
Defines @racket[id] behave like a Racket binding, but @racket[id] is
actually redirected through a parameter-like procedure created by
@racket[make-c-parameter]. The @racket[id] is used both for the Racket
binding and for the foreign object's name.}
binding and for the foreign name.}
@defproc[(ffi-obj-ref [objname (or/c string? bytes? symbol?)]
[lib (or/c ffi-lib? path-string? #f)]
[failure-thunk (or/c (-> any) #f) #f])
any]{
Returns a pointer object for the specified foreign object. This
procedure is for rare cases where @racket[make-c-parameter] is
insufficient, because there is no type to cast the foreign object to
(e.g., a vector of numbers).}
Returns a pointer for the specified foreign name, calls
@racket[failure-thunk] if the name is not found, or raises an
exception if @racket[failure-thunk] is @racket[#f].
Normally, @racket[get-ffi-obj] should be used, instead.}

7
collects/scribblings/foreign/pointers.scrbl
View File

@ -16,9 +16,10 @@ property}. Returns @racket[#f] for other values.}
Compares the values of the two pointers. Two different Racket
pointer objects can contain the same pointer.
If the values are both C pointers---as opposed to @racket[#f], a byte
string, @racket[ffi-obj], or callback---this comparison is the same as
@racket[equal?].}
If the values are both pointers that are not represented by
@racket[#f], a byte string, a callback, or a pointer based on
@racket[_fpointer], then the @racket[ptr-equal?] comparison is the
same as using @racket[equal?].}
@defproc[(ptr-add [cptr cpointer?] [offset exact-integer?] [type ctype? _byte])

20
collects/scribblings/foreign/types.scrbl
View File

@ -358,16 +358,18 @@ Racket's C API.}
@defthing[_fpointer ctype?]{
Similar to @racket[_pointer], except that when an @racket[_fpointer]
is extracted from a pointer produced by @racket[ffi-obj-ref], then a
level of indirection is skipped. A level of indirection is similarly
skipped when extracting a pointer via @racket[get-ffi-obj]. Like
@racket[_pointer], @racket[_fpointer] treats @racket[#f] as @cpp{NULL}
and vice versa.
Similar to @racket[_pointer], except that when @racket[_fpointer] is
used as the type for @racket[get-ffi-obj] or @racket[ffi-obj-ref],
then a level of indirection is skipped. Furthermore, for a C pointer
value from @racket[get-ffi-obj] or @racket[ffi-obj-ref] using
@racket[_fpointer], @racket[ptr-ref] on the pointer as a
@racket[_fpointer] simply returns the pointer instead of dereferencing
it. Like @racket[_pointer], @racket[_fpointer] treats @racket[#f] as
@cpp{NULL} and vice versa.
A type generated by @racket[_cprocedure] builds on @racket[_fpointer],
and normally @racket[_cprocedure] should be used instead of
@racket[_fpointer].}
A type generated by @racket[_cprocedure] or @racket[_fun] builds on
@racket[_fpointer], and normally @racket[_cprocedure] or @racket[_fun]
should be used instead of @racket[_fpointer].}
@defproc[(_or-null [ctype ctype?]) ctype?]{

44
collects/scribblings/foreign/unexported.scrbl
View File

@ -12,17 +12,15 @@
Parts of the @racketmodname[ffi/unsafe] library are implemented by
the Racket built-in @racketmodname['#%foreign] module. The
@racketmodname['#%foreign] module is not intended for direct use, but
it exports the following procedures. If you find any of these useful,
please let us know.
it exports the following procedures (among others).
@defproc[(ffi-obj [objname (or/c string? bytes? symbol?)]
[lib (or/c ffi-lib? path-string? #f)])
any]{
ffi-obj?]{
Pulls out a foreign object from a library, returning a Racket value
that can be used as a pointer. If a name is provided instead of a
foreign-library value, @racket[ffi-lib] is used to create a library
object.}
Pulls out a foreign object from a library, returning a value
that can be used as a C pointer. If @racket[lib] is a path or string,
then @racket[ffi-lib] is used to create a library object.}
@defproc*[([(ffi-obj? [x any/c]) boolean?]
@ -44,33 +42,27 @@ symbol for primitive types that names the type, a list of ctypes for
cstructs, and another ctype for user-defined ctypes.}
@defproc[(ffi-call [ptr any/c] [in-types (listof ctype?)] [out-type ctype?]
[abi (or/c symbol/c #f) #f])
any]{
@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])
procedure?]{
The primitive mechanism that creates Racket ``callout'' values. The
given @racket[ptr] (any pointer value, including @racket[ffi-obj]
values) is wrapped in a Racket-callable primitive function that uses
the types to specify how values are marshaled.
The optional @racket[abi] argument determines the foreign ABI that is
used. @racket[#f] or @racket['default] will use a platform-dependent
default; other possible values are @racket['stdcall] and
@racket['sysv] (the latter corresponds to ``cdecl''). This is
especially important on Windows, where most system functions are
@racket['stdcall], which is not the default.}
The primitive mechanism that creates Racket ``callout'' values for
@racket[_cprocedure]. The given @racket[ptr] is wrapped in a
Racket-callable primitive function that uses the types to specify how
values are marshaled.}
@defproc[(ffi-callback [proc any/c] [in-types any/c] [out-type any/c]
[abi (or/c symbol/c #f) #f]
[atomic? any/c #f])
[abi (or/c #f 'default 'stdcall 'sysv) #f]
[atomic? any/c #f]
[async-apply (or/c #f ((-> any) . -> . any)) #f])
ffi-callback?]{
The symmetric counterpart of @racket[ffi-call]. It receives a Racket
procedure and creates a callback object, which can also be used as a
pointer. This object can be used as a C-callable function, which
invokes @racket[proc] using the types to specify how values are
marshaled.}
C pointer.}
@defproc[(ffi-callback? [x any/c]) boolean?]{

5
collects/tests/racket/foreign-test.rktl
View File

@ -195,8 +195,9 @@
(test* 4 'g3 _pointer (lambda (p) ((function-ptr p (_fun _int -> _int)) 3)))
;; Equivalentlly, 'g3 is a static variable that holds a function pointer. By
;; looking it up with _fpointer, we get its address, which then works
;; with ptr-ref to extract the function.
(test* 7 'g3 _fpointer (lambda (p) ((ptr-ref p (_fun _int -> _int)) 6)))
;; with ptr-ref to extract the function. (This pattern isn't a good idea, but
;; it's a useful extra check here.)
(test* 7 'g3 _fpointer (lambda (p) ((ptr-ref (cast p _fpointer _pointer) (_fun _int -> _int)) 6)))
;; ---
(test ((lambda (x f) ((f (+ x 1)) (- x 1)))
3 (lambda (x) (lambda (y) (+ y (* x x)))))

551
src/foreign/foreign.c
View File

File diff suppressed because it is too large Load Diff

415
src/foreign/foreign.rktc
View File

@ -207,7 +207,7 @@ THREAD_LOCAL_DECL(static Scheme_Hash_Table *opened_libs);
int null_ok = 0, as_global = 0;
ffi_lib_struct *lib;
if (!(SCHEME_PATH_STRINGP(argv[0]) || SCHEME_FALSEP(argv[0])))
scheme_wrong_type(MYNAME, "string-or-false", 0, argc, argv);
scheme_wrong_contract(MYNAME, "(or/c string? #f)", 0, argc, argv);
as_global = ((argc > 2) && SCHEME_TRUEP(argv[2]));
/* leave the filename as given, the system will look for it */
/* (`#f' means open the executable) */
@ -253,7 +253,7 @@ THREAD_LOCAL_DECL(static Scheme_Hash_Table *opened_libs);
/* (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);
scheme_wrong_contract(MYNAME, "ffi-lib?", 0, argc, argv);
return ((ffi_lib_struct*)argv[0])->name;
}
@ -276,9 +276,9 @@ THREAD_LOCAL_DECL(static Scheme_Hash_Table *opened_libs);
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);
scheme_wrong_contract(MYNAME, "ffi-lib?", 1, argc, argv);
if (!SCHEME_BYTE_STRINGP(argv[0]))
scheme_wrong_type(MYNAME, "bytes", 0, argc, argv);
scheme_wrong_contract(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) {
@ -350,14 +350,14 @@ THREAD_LOCAL_DECL(static Scheme_Hash_Table *opened_libs);
/* (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);
scheme_wrong_contract(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);
scheme_wrong_contract(MYNAME, "ffi-obj?", 0, argc, argv);
return scheme_make_byte_string(((ffi_obj_struct*)argv[0])->name);
}
@ -563,12 +563,12 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* Predicate: @(cond [(not pred) "-none-"]
[(procedure? pred) (pred "<Scheme>" "aux")]
[else @list{@|pred|(<Scheme>)}])
* Scheme->C: @(cond [(not s->c)
* Racket->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-"]
* C->Racket: @(cond [(not c->s) "-none-"]
[(procedure? c->s) (c->s "<C>")]
[else @list{@|c->s|(<C>)}])
*/})
@ -852,8 +852,9 @@ typedef union _ForeignAny {
#define FOREIGN_union (@(type-counter 'last))
static int is_gcable_pointer(Scheme_Object *o) {
return !SCHEME_CPTRP(o)
|| !(SCHEME_CPTR_FLAGS(o) & 0x1);
if (SCHEME_FFIOBJP(o)) return 0;
return (!SCHEME_CPTRP(o)
|| !(SCHEME_CPTR_FLAGS(o) & 0x1));
}
/*****************************************************************************/
@ -890,20 +891,20 @@ static ffi_type ffi_type_gcpointer;
/* Returns #f for primitive types. */
@cdefine[ctype-basetype 1]{
if (!SCHEME_CTYPEP(argv[0]))
scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
scheme_wrong_contract(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);
scheme_wrong_contract(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);
scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
return (CTYPE_PRIMP(argv[0])) ? scheme_false :
((ctype_struct*)(argv[0]))->c_to_scheme;
}
@ -936,11 +937,11 @@ static intptr_t ctype_sizeof(Scheme_Object *type)
@cdefine[make-ctype 3]{
ctype_struct *type;
if (!SCHEME_CTYPEP(argv[0]))
scheme_wrong_type(MYNAME, "C-type", 0, argc, argv);
scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
else if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1])))
scheme_wrong_type(MYNAME, "procedure-or-false", 1, argc, argv);
scheme_wrong_contract(MYNAME, "(or/c procedure? #f)", 1, argc, argv);
else if (!(SCHEME_FALSEP(argv[2]) || SCHEME_PROCP(argv[2])))
scheme_wrong_type(MYNAME, "procedure-or-false", 2, argc, argv);
scheme_wrong_contract(MYNAME, "(or/c procedure? #f)", 2, argc, argv);
else if (SCHEME_FALSEP(argv[1]) && SCHEME_FALSEP(argv[2]))
return argv[0];
else {
@ -1001,6 +1002,36 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
/*****************************************************************************/
/* cstruct types */
static void wrong_void(const char *who, Scheme_Object *list_element, int specifically_void,
int which, int argc, Scheme_Object **argv)
{
intptr_t len;
char *s;
if (argc > 1)
s = scheme_make_arg_lines_string(" ", which, argc, argv, &len);
else
s = NULL;
if (list_element) {
scheme_contract_error(who,
(specifically_void
? "C type within list is based on _void"
: "C type within list has a zero size"),
"C type", 1, list_element,
"list", 1, argv[which],
s ? "other arguments" : NULL, 0, s,
NULL);
} else
scheme_contract_error(who,
(specifically_void
? "given C type is based on _void"
: "given C type has a zero size"),
"given C type", 1, argv[which],
s ? "other arguments" : NULL, 0, s,
NULL);
}
/* (make-cstruct-type types [abi alignment]) -> ctype */
/* This creates a new primitive type that is a struct. This type can be used
* with cpointer objects, except that the contents is used rather than the
@ -1016,7 +1047,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
int i, nargs, with_alignment;
ffi_abi abi;
nargs = scheme_proper_list_length(argv[0]);
if (nargs < 0) scheme_wrong_type(MYNAME, "proper list", 0, argc, argv);
if (nargs < 0) scheme_wrong_contract(MYNAME, "list?", 0, argc, argv);
abi = GET_ABI(MYNAME,1);
if (argc > 2) {
if (!SCHEME_FALSEP(argv[2])) {
@ -1025,7 +1056,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
&& !SAME_OBJ(argv[2], scheme_make_integer(4))
&& !SAME_OBJ(argv[2], scheme_make_integer(8))
&& !SAME_OBJ(argv[2], scheme_make_integer(16)))
scheme_wrong_type(MYNAME, "1, 2, 4, 8, 16, or #f", 2, argc, argv);
scheme_wrong_contract(MYNAME, "(or/c 1 2 4 8 16 #f)", 2, argc, argv);
with_alignment = SCHEME_INT_VAL(argv[2]);
} else
with_alignment = 0;
@ -1036,9 +1067,9 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
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);
scheme_wrong_contract(MYNAME, "(listof ctype?)", 0, argc, argv);
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 0, argc, argv);
wrong_void(MYNAME, SCHEME_CAR(p), 1, 0, argc, argv);
elements[i] = CTYPE_PRIMTYPE(base);
if (with_alignment) {
/* copy the type to set an alignment: */
@ -1072,6 +1103,27 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
/*****************************************************************************/
/* array types */
static void wrong_intptr(const char *who, int which, int argc, Scheme_Object **argv)
{
if (!SCHEME_INTP(argv[which]) && !SCHEME_BIGNUMP(argv[which])) {
scheme_wrong_contract(who, "exact-integer?", which, argc, argv);
} else {
intptr_t len;
char *s;
if (argc > 1)
s = scheme_make_arg_lines_string(" ", which, argc, argv, &len);
else
s = NULL;
scheme_contract_error(who,
"given integer does not fit into the _intptr type",
"given integer", 1, argv[which],
s ? "other arguments" : NULL, 0, s,
NULL);
}
}
/* (make-array-type type len) -> ctype */
/* This creates a new primitive type that is an array. An array is the
* same as a cpointer as an argument, but it behave differently within
@ -1084,9 +1136,14 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
intptr_t len, size;
if (NULL == (base = get_ctype_base(argv[0])))
scheme_wrong_type(MYNAME, "C-type", 0, argc, argv);
if (!scheme_get_int_val(argv[1], &len) || (len < 0))
scheme_wrong_type(MYNAME, "pointer-sized nonnegative exact integer", 1, argc, argv);
scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
if (!scheme_get_int_val(argv[1], &len) || (len < 0)) {
if ((SCHEME_INTP(argv[1]) && SCHEME_INT_VAL(argv[1]) > 0)
|| (SCHEME_BIGNUMP(argv[1]) && SCHEME_BIGPOS(argv[1])))
wrong_intptr(MYNAME, 1, argc, argv);
else
scheme_wrong_contract(MYNAME, "exact-nonnegative-integer?", 1, argc, argv);
}
/* libffi doesn't seem to support array types, but we try to make
libffi work anyway by making a structure type that is used when
@ -1153,7 +1210,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
for (i = 0; i < argc; i++) {
if (NULL == (base = get_ctype_base(argv[i]))) {
free(elements);
scheme_wrong_type(MYNAME, "C-type", i, argc, argv);
scheme_wrong_contract(MYNAME, "ctype?", i, argc, argv);
}
a = CTYPE_PRIMTYPE(base)->alignment;
if (a > align) align = a;
@ -1277,7 +1334,7 @@ static Scheme_Object *unwrap_cpointer_property(Scheme_Object *orig_v)
}
if (must && !SCHEME_FFIANYPTRP(v)) {
scheme_wrong_type("prop:cpointer accessor", "cpointer", 0, -1, &v);
scheme_wrong_contract("prop:cpointer accessor", "cpointer?", 0, -1, &v);
return NULL;
}
@ -1299,7 +1356,7 @@ int scheme_is_cpointer(Scheme_Object *cp) {
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
if (SCHEME_CPTRP(cp)) tag = SCHEME_CPTR_TYPE(cp);
return (tag == NULL) ? scheme_false : tag;
}
@ -1308,7 +1365,7 @@ int scheme_is_cpointer(Scheme_Object *cp) {
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_CPTRP(cp))
scheme_wrong_type(MYNAME, "proper-cpointer", 0, argc, argv);
scheme_wrong_contract(MYNAME, "propert-cpointer?", 0, argc, argv);
SCHEME_CPTR_TYPE(cp) = argv[1];
return scheme_void;
}
@ -1318,35 +1375,36 @@ void *scheme_extract_pointer(Scheme_Object *v) {
}
/*****************************************************************************/
/* Scheme<-->C conversions */
/* Racket<-->C conversions */
/* On big endian machines we need to know whether we're pulling a value from an
* argument location where it always takes a whole word or straight from a
* memory location -- deal with it via a C2SCHEME macro wrapper that is used
* for both the function definition and calls */
#ifdef SCHEME_BIG_ENDIAN
#define C2SCHEME(typ,src,delta,argsloc,gcsrc) c_to_scheme(typ,src,delta,argsloc,gcsrc)
#define C2SCHEME(ap,typ,src,delta,argsloc,gcsrc) c_to_scheme(ap,typ,src,delta,argsloc,gcsrc)
#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,gcsrc) c_to_scheme(typ,src,delta,gcsrc)
#define C2SCHEME(ap,typ,src,delta,argsloc,gcsrc) c_to_scheme(ap,typ,src,delta,gcsrc)
#define REF_CTYPE(ctype) (((ctype *)W_OFFSET(src,delta))[0])
#endif
static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
static Scheme_Object *C2SCHEME(Scheme_Object *already_ptr, Scheme_Object *type, void *src,
intptr_t delta, int args_loc, int gcsrc)
{
Scheme_Object *res;
if (!SCHEME_CTYPEP(type))
scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
scheme_wrong_contract("C->Racket", "ctype?", 0, 1, &type);
if (CTYPE_USERP(type)) {
res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc, gcsrc);
res = C2SCHEME(already_ptr, CTYPE_BASETYPE(type), src, delta, args_loc, gcsrc);
if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
return res;
else
return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res));
} else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
if (already_ptr) return already_ptr;
return scheme_make_foreign_external_cpointer(*(void **)W_OFFSET(src, delta));
} else switch (CTYPE_PRIMLABEL(type)) {
@(map-types
@ -1368,6 +1426,15 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
}
#undef REF_CTYPE
static void wrong_value(const char *who, const char *type, Scheme_Object *val)
{
scheme_contract_error(who,
"given value does not fit primitive C type",
"C type", 0, type,
"given value", 1, val,
NULL);
}
/* 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
@ -1379,12 +1446,13 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
* NULL, then any pointer value (any pointer or a struct or array) is returned, and the
* basetype_p is set to the corrsponding number tag. If basetype_p is NULL,
* then a struct or array value will be *copied* into dst. */
static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
static void* SCHEME2C(const char *who,
Scheme_Object *type, void *dst, intptr_t delta,
Scheme_Object *val, intptr_t *basetype_p, intptr_t *_offset,
int ret_loc)
{
if (!SCHEME_CTYPEP(type))
scheme_wrong_type("Scheme->C", "C-type", 0, 1, &type);
scheme_wrong_contract(who, "ctype?", 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));
@ -1402,11 +1470,11 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
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);
wrong_value(who, "_fpointer", 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{wrong_value(who, "_@type", val);})
@list{
case FOREIGN_@|cname|:
@(let* ([x (and ctype @list{(((@|ctype|*)W_OFFSET(dst,delta))[0])})]
@ -1414,7 +1482,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
(if (procedure? p) @p["val" x] @list{@|p|(val)}))])
(cond
[(not x)
@list{if (!ret_loc) @wrong-type["type" "non-void-C-type"];
@list{if (!ret_loc) @wrong-type["type" "void"];
break;
}]
[(not s->c)
@ -1470,8 +1538,20 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
case FOREIGN_struct:
case FOREIGN_array:
case FOREIGN_union:
if (!SCHEME_FFIANYPTRP(val))
scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);
if (!SCHEME_FFIANYPTRP(val)) {
switch (CTYPE_PRIMLABEL(type)) {
case FOREIGN_struct:
wrong_value(who, "(_struct ....)", val);
break;
case FOREIGN_array:
wrong_value(who, "(_array ....)", val);
break;
default:
case FOREIGN_union:
wrong_value(who, "(_union ....)", val);
break;
}
}
{
void* p = SCHEME_FFIANYPTR_VAL(val);
intptr_t poff = SCHEME_FFIANYPTR_OFFSET(val);
@ -1505,7 +1585,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
intptr_t size;
size = ctype_sizeof(argv[0]);
if (size >= 0) return scheme_make_integer(size);
else scheme_wrong_type(MYNAME, "C-type", 0, argc, argv);
else scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
return NULL; /* hush the compiler */
}
@ -1513,7 +1593,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
@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);
if (type == NULL) scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
else return scheme_make_integer(CTYPE_PRIMTYPE(type)->alignment);
return NULL; /* hush the compiler */
}
@ -1534,7 +1614,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
else if (must_list) { p = scheme_false; l = scheme_null; }
else { p = l; l = scheme_null; }
if (!SCHEME_SYMBOLP(p)) {
scheme_wrong_type(MYNAME, "symbol or list of symbols", 0, argc, argv);
scheme_wrong_contract(MYNAME, "(or/c symbol? (listof symbol?))", 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);
@ -1561,7 +1641,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
} else if (!strcmp(SCHEME_SYM_VAL(p),"*")) {
stars++;
} else {
scheme_wrong_type(MYNAME, "C type symbol or list of C type symbols", 0, argc, argv);
scheme_wrong_contract(MYNAME, "(or/c ctype-symbol? (listof ctype-symbol?))", 0, argc, argv);
}
}
if (stars > 1)
@ -1649,15 +1729,15 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
scheme_signal_error(MYNAME": specifying a second integer size: %V", a);
num = SCHEME_INT_VAL(a);
if (num < 0)
scheme_wrong_type(MYNAME, "nonnegative fixnum", 0, argc, argv);
scheme_wrong_contract(MYNAME, "(and/c exact-nonnegative-integer? fixnum?)", 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);
scheme_wrong_contract(MYNAME, "ctype?", i, argc, argv);
size = ctype_sizeof(a);
if (size <= 0)
scheme_wrong_type(MYNAME, "non-void-C-type", i, argc, argv);
wrong_void(MYNAME, NULL, 0, i, argc, argv);
} else if (SAME_OBJ(a, fail_ok_sym)) {
failok = 1;
} else if (SCHEME_SYMBOLP(a)) {
@ -1671,7 +1751,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
from = SCHEME_FFIANYPTR_VAL(a);
foff = SCHEME_FFIANYPTR_OFFSET(a);
} else {
scheme_wrong_type(MYNAME, "malloc-argument", i, argc, argv);
scheme_wrong_contract(MYNAME,
"(or/c (and/c exact-nonnegative-integer? fixnum?)\n"
" ctype?\n"
" (or/c 'nonatomic 'stubborn 'uncollectable\n"
" 'eternal 'interior 'atomic-interior 'raw)\n"
" 'fail-on\n"
" (and/c cpointer? (not/c #f)))",
i, argc, argv);
}
}
if (!num) return scheme_false;
@ -1702,6 +1789,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
return scheme_make_foreign_cpointer(res);
}
#define NON_NULL_CPOINTER "(and/c cpointer? (not/c (lambda (p) (pointer-equal? p #f))))"
/* (end-stubborn-change ptr) */
@cdefine[end-stubborn-change 1]{
void *ptr;
@ -1709,11 +1798,11 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(cp);
poff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv);
scheme_end_stubborn_change(W_OFFSET(ptr, poff));
return scheme_void;
}
@ -1727,11 +1816,11 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(cp);
poff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv);
free(W_OFFSET(ptr, poff));
return scheme_void;
}
@ -1750,17 +1839,15 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(cp);
poff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv);
scheme_free_immobile_box((void **)W_OFFSET(ptr, poff));
return scheme_void;
}
#define C_INTPTR_T_TYPE_STR "exact integer that fits a C intptr_t"
/* (ptr-add cptr offset-k [type])
* Adds an offset to a pointer, returning an offset_cpointer value
* (ptr-add! cptr offset-k [type])
@ -1775,21 +1862,23 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang,
cp = unwrap_cpointer_property(argv[0]);
if (is_bang) {
if (!SCHEME_CPOINTER_W_OFFSET_P(cp))
scheme_wrong_type(who, "offset-cpointer", 0, argc, argv);
scheme_wrong_contract(who, "offset-ptr?", 0, argc, argv);
} else {
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(who, "cpointer", 0, argc, argv);
scheme_wrong_contract(who, "cpointer?", 0, argc, argv);
}
if (!scheme_get_int_val(argv[1], &noff))
scheme_wrong_type(who, C_INTPTR_T_TYPE_STR, 1, argc, argv);
wrong_intptr(who, 1, argc, argv);
if (argc > 2) {
if (SCHEME_CTYPEP(argv[2])) {
intptr_t size;
size = ctype_sizeof(argv[2]);
if (size <= 0) scheme_wrong_type(who, "non-void-C-type", 2, argc, argv);
if (size < 0)
scheme_wrong_contract(who, "ctype?", 2, argc, argv);
if (size <= 0) wrong_void(who, NULL, 0, 2, argc, argv);
noff = mult_check_overflow(who, noff, size);
} else
scheme_wrong_type(who, "C-type", 2, argc, argv);
scheme_wrong_contract(who, "ctype?", 2, argc, argv);
}
if (is_bang) {
intptr_t delta;
@ -1831,7 +1920,7 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang,
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
return scheme_make_integer_value(SCHEME_FFIANYPTR_OFFSET(cp));
}
@ -1843,21 +1932,20 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang,
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_CPOINTER_W_OFFSET_P(cp))
scheme_wrong_type(MYNAME, "offset-cpointer", 0, argc, argv);
if (!scheme_get_int_val(argv[1], &noff)) {
scheme_wrong_type(MYNAME, C_INTPTR_T_TYPE_STR, 1, argc, argv);
}
scheme_wrong_contract(MYNAME, "offset-ptr?", 0, argc, argv);
if (!scheme_get_int_val(argv[1], &noff))
wrong_intptr(MYNAME, 1, argc, argv);
if (argc > 2) {
if (SCHEME_CTYPEP(argv[2])) {
intptr_t size;
if (NULL == get_ctype_base(argv[2]))
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
scheme_wrong_contract(MYNAME, "ctype?", 2, argc, argv);
size = ctype_sizeof(argv[2]);
if (size <= 0)
scheme_wrong_type(MYNAME, "non-void-C-type", 2, argc, argv);
wrong_void(MYNAME, NULL, 0, 2, argc, argv);
noff = mult_check_overflow(MYNAME, noff, size);
} else
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
scheme_wrong_contract(MYNAME, "ctype?", 2, argc, argv);
}
((Scheme_Offset_Cptr*)(cp))->offset = noff;
return scheme_void;
@ -1887,14 +1975,16 @@ static Scheme_Object *do_memop(const char *who, int mode,
if (SCHEME_CTYPEP(argv[argc1-1])) {
argc1--;
mult = ctype_sizeof(argv[argc1]);
if (mult < 0)
scheme_wrong_contract(who, "ctype?", argc1, argc, argv);
if (mult <= 0)
scheme_wrong_type(who, "non-void-C-type", argc1, argc, argv);
wrong_void(who, NULL, 0, argc1, argc, argv);
}
/* get the count argument */
argc1--;
if ((!scheme_get_int_val(argv[argc1], &count)) || (count < 0))
scheme_wrong_type(who, "count as " C_INTPTR_T_TYPE_STR, argc1, argc, argv);
wrong_intptr(who, argc1, argc, argv);
if (mult) count *= mult;
/* get the fill byte for memset */
@ -1902,7 +1992,7 @@ static Scheme_Object *do_memop(const char *who, int 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);
scheme_wrong_contract(who, "byte?", argc1, argc, argv);
}
/* get the two pointers + offsets */
@ -1915,7 +2005,7 @@ static Scheme_Object *do_memop(const char *who, int mode,
who, (j == 0 ? "destination" : "source"));
cp = unwrap_cpointer_property(argv[i]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(who, "cpointer", i, argc, argv);
scheme_wrong_contract(who, "cpointer?", i, argc, argv);
switch (j) {
case 0: dest = SCHEME_FFIANYPTR_VAL(cp);
doff = SCHEME_FFIANYPTR_OFFSET(cp);
@ -1927,7 +2017,7 @@ static Scheme_Object *do_memop(const char *who, int mode,
i++;
if ((i<argc1) && SCHEME_EXACT_INTEGERP(argv[i])) {
if (!scheme_get_int_val(argv[i], &v))
scheme_wrong_type(who, C_INTPTR_T_TYPE_STR, i, argc, argv);
wrong_intptr(who, i, argc, argv);
if (mult) v *= mult;
switch (j) {
case 0: doff += v; break;
@ -1952,13 +2042,13 @@ static Scheme_Object *do_memop(const char *who, int mode,
@cdefine[vector->cpointer 1]{
if (!SCHEME_VECTORP(argv[0]))
scheme_wrong_type(MYNAME, "vector", 0, argc, argv);
scheme_wrong_contract(MYNAME, "vector?", 0, argc, argv);
return scheme_make_offset_cptr(argv[0], (intptr_t)SCHEME_VEC_ELS((Scheme_Object *)0x0), NULL);
}
@cdefine[flvector->cpointer 1]{
if (!SCHEME_FLVECTORP(argv[0]))
scheme_wrong_type(MYNAME, "flvector", 0, argc, argv);
scheme_wrong_contract(MYNAME, "flvector?", 0, argc, argv);
return scheme_make_offset_cptr(argv[0], (intptr_t)SCHEME_FLVEC_ELS((Scheme_Object *)0x0), NULL);
}
@ -1976,18 +2066,18 @@ static Scheme_Object *do_memop(const char *who, int mode,
@cdefine[ptr-ref 2 4]{
intptr_t size=0; void *ptr; Scheme_Object *base;
intptr_t delta; int gcsrc=1;
Scheme_Object *cp;
Scheme_Object *cp, *already_ptr = NULL;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(cp);
delta = SCHEME_FFIANYPTR_OFFSET(cp);
if (!is_gcable_pointer(cp))
gcsrc = 0;
if ((ptr == NULL) && (delta == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv);
if (NULL == (base = get_ctype_base(argv[1])))
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
scheme_wrong_contract(MYNAME, "ctype?", 1, argc, argv);
size = ctype_sizeof(base);
if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
@ -1995,30 +2085,38 @@ static Scheme_Object *do_memop(const char *who, int mode,
/* The ffiobj pointer is the function pointer. */
ptr = cp;
delta = (intptr_t)&(((ffi_obj_struct*)0x0)->obj);
/* Helps propagate a function name from `ffi-obj' to `ffi-call': */
already_ptr = cp;
}
}
if (size < 0) {
/* should not happen */
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
scheme_wrong_contract(MYNAME, "ctype?", 1, argc, argv);
} else if (size == 0) {
scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
wrong_void(MYNAME, NULL, 0, 1, argc, argv);
}
if (argc > 3) {
if (!SAME_OBJ(argv[2],abs_sym))
scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
scheme_wrong_contract(MYNAME, "'abs", 2, argc, argv);
if (!SCHEME_INTP(argv[3]))
scheme_wrong_type(MYNAME, "fixnum", 3, argc, argv);
delta = add_check_overflow(MYNAME, delta, SCHEME_INT_VAL(argv[3]));
scheme_wrong_contract(MYNAME, "fixnum?", 3, argc, argv);
if (SCHEME_INT_VAL(argv[3])) {
delta = add_check_overflow(MYNAME, delta, SCHEME_INT_VAL(argv[3]));
already_ptr = NULL;
}
} else if (argc > 2) {
if (!SCHEME_INTP(argv[2]))
scheme_wrong_type(MYNAME, "fixnum", 2, argc, argv);
scheme_wrong_contract(MYNAME, "fixnum?", 2, argc, argv);
if (!size)
scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
delta = add_check_overflow(MYNAME, delta, mult_check_overflow(MYNAME, size, SCHEME_INT_VAL(argv[2])));
if (SCHEME_INT_VAL(argv[2])) {
delta = add_check_overflow(MYNAME, delta, mult_check_overflow(MYNAME, size, SCHEME_INT_VAL(argv[2])));
already_ptr = NULL;
}
}
return C2SCHEME(argv[1], ptr, delta, 0, gcsrc);
return C2SCHEME(already_ptr, argv[1], ptr, delta, 0, gcsrc);
}
/* (ptr-set! cpointer type [['abs] n] value) -> void */
@ -2033,36 +2131,36 @@ static Scheme_Object *do_memop(const char *who, int mode,
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(cp);
delta = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (delta == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv);
if (NULL == (base = get_ctype_base(argv[1])))
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
scheme_wrong_contract(MYNAME, "ctype?", 1, argc, argv);
size = ctype_sizeof(base);
if (size < 0) {
/* should not happen */
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
scheme_wrong_contract(MYNAME, "ctype?", 1, argc, argv);
} else if (size == 0) {
scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
wrong_void(MYNAME, NULL, 0, 1, argc, argv);
}
if (argc > 4) {
if (!SAME_OBJ(argv[2],abs_sym))
scheme_wrong_type(MYNAME, "'abs", 2, argc, argv);
scheme_wrong_contract(MYNAME, "'abs", 2, argc, argv);
if (!SCHEME_INTP(argv[3]))
scheme_wrong_type(MYNAME, "fixnum", 3, argc, argv);
scheme_wrong_contract(MYNAME, "fixnum?", 3, argc, argv);
delta = add_check_overflow(MYNAME, delta, SCHEME_INT_VAL(argv[3]));
} else if (argc > 3) {
if (!SCHEME_INTP(argv[2]))
scheme_wrong_type(MYNAME, "fixnum", 2, argc, argv);
scheme_wrong_contract(MYNAME, "fixnum?", 2, argc, argv);
if (!size)
scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
delta = add_check_overflow(MYNAME, delta, mult_check_overflow(MYNAME, size, SCHEME_INT_VAL(argv[2])));
}
SCHEME2C(argv[1], ptr, delta, val, NULL, NULL, 0);
SCHEME2C(MYNAME, argv[1], ptr, delta, val, NULL, NULL, 0);
return scheme_void;
}
@ -2072,9 +2170,9 @@ static Scheme_Object *do_memop(const char *who, int mode,
cp1 = unwrap_cpointer_property(argv[0]);
cp2 = unwrap_cpointer_property(argv[1]);
if (!SCHEME_FFIANYPTRP(cp1))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
if (!SCHEME_FFIANYPTRP(cp2))
scheme_wrong_type(MYNAME, "cpointer", 1, argc, argv);
scheme_wrong_contract(MYNAME, "cpointer?", 1, argc, argv);
return (SAME_OBJ(cp1, cp2) ||
(SCHEME_FFIANYPTR_OFFSETVAL(cp1)
== SCHEME_FFIANYPTR_OFFSETVAL(cp2)))
@ -2091,9 +2189,9 @@ static Scheme_Object *do_memop(const char *who, int mode,
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
if (!scheme_get_int_val(argv[1],&len))
scheme_wrong_type(MYNAME, "integer in a C intptr_t range", 1, argc, argv);
wrong_intptr(MYNAME, 1, argc, argv);
if (SCHEME_FALSEP(cp)) return scheme_false;
else return
scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(cp),
@ -2121,44 +2219,6 @@ void do_ptr_finalizer(void *p, void *finalizer)
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);
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (ptrsym) {
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(cp);
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 = cp;
}
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 */
@ -2312,8 +2372,7 @@ static void finish_ffi_call(ffi_cif *cif, void *c_func, intptr_t cfoff,
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]); */
const 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];
@ -2364,7 +2423,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
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,
p = SCHEME2C(name, SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype,
&offset, 0);
if ((p != NULL) || offset) {
avalues[i] = p;
@ -2416,7 +2475,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
p = *(void **)p;
break;
}
return C2SCHEME(otype, p, 0, 1, 1);
return C2SCHEME(NULL, otype, p, 0, 1, 1);
}
/* see below */
@ -2426,14 +2485,14 @@ void free_fficall_data(void *ignored, void *p)
free(p);
}
static Scheme_Object *ffi_name_prefix = NULL;
static Scheme_Object *ffi_name = NULL;
/* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place?]) -> (in-types -> out-value) */
/* the real work is done by ffi_do_call above */
@cdefine[ffi-call 3 6]{
Scheme_Object *itypes = argv[1];
Scheme_Object *otype = argv[2];
Scheme_Object *obj, *data, *p, *base, *cp;
Scheme_Object *obj, *data, *p, *base, *cp, *name;
ffi_abi abi;
intptr_t ooff;
GC_CAN_IGNORE ffi_type *rtype, **atypes;
@ -2447,16 +2506,16 @@ static Scheme_Object *ffi_name_prefix = NULL;
}
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv);
scheme_wrong_contract(MYNAME, "(or/c ffi-obj? cpointer?)", 0, argc, argv);
obj = SCHEME_FFIANYPTR_VAL(cp);
ooff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((obj == NULL) && (ooff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_wrong_contract(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);
scheme_wrong_contract(MYNAME, "list?", 1, argc, argv);
if (NULL == (base = get_ctype_base(otype)))
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
scheme_wrong_contract(MYNAME, "ctype?", 2, argc, argv);
rtype = CTYPE_ARG_PRIMTYPE(base);
abi = GET_ABI(MYNAME,3);
if (argc > 4) {
@ -2471,7 +2530,7 @@ static Scheme_Object *ffi_name_prefix = NULL;
save_errno = 2;
}
if (save_errno == -1) {
scheme_wrong_type(MYNAME, "'posix, 'windows, or #f", 4, argc, argv);
scheme_wrong_contract(MYNAME, "(or/c 'posix 'windows #f)", 4, argc, argv);
}
} else
save_errno = 0;
@ -2479,24 +2538,23 @@ static Scheme_Object *ffi_name_prefix = NULL;
if (argc > 5) orig_place = SCHEME_TRUEP(argv[5]);
else orig_place = 0;
}
if (SCHEME_FFIOBJP(cp))
name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name);
else
name = ffi_name;
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);
scheme_wrong_contract(MYNAME, "(listof ctype?)", 1, argc, argv);
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv);
wrong_void(MYNAME, SCHEME_CAR(p), 1, 1, argc, argv);
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");
data = scheme_make_vector(FFI_CALL_VEC_SIZE, NULL);
p = scheme_append_byte_string
(ffi_name_prefix,
scheme_make_byte_string_without_copying
(SCHEME_FFIOBJP(cp) ?
((ffi_obj_struct*)(cp))->name : "proc"));
SCHEME_VEC_ELS(data)[0] = p;
SCHEME_VEC_ELS(data)[0] = name;
SCHEME_VEC_ELS(data)[1] = obj;
SCHEME_VEC_ELS(data)[2] = itypes;
SCHEME_VEC_ELS(data)[3] = otype;
@ -2507,9 +2565,9 @@ static Scheme_Object *ffi_name_prefix = NULL;
SCHEME_VEC_ELS(data)[7] = (orig_place ? scheme_true : scheme_false);
}
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);
return scheme_make_closed_prim_w_arity(ffi_do_call, (void*)data,
SCHEME_BYTE_STR_VAL(name),
nargs, nargs);
}
/*****************************************************************************/
@ -2555,13 +2613,13 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
t = SCHEME_CAR(p);
if (CTYPE_PRIMLABEL(get_ctype_base(t)) == FOREIGN_array) {
/* array as argument is treated as a pointer */
v = C2SCHEME(t, *(void **)(args[i]), 0, 0, 0);
v = C2SCHEME(NULL, t, *(void **)(args[i]), 0, 0, 0);
} else
v = C2SCHEME(t, args[i], 0, 0, 0);
v = C2SCHEME(NULL, t, args[i], 0, 0, 0);
argv[i] = v;
}
p = _scheme_apply(data->proc, argc, argv);
SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1);
SCHEME2C("callback result", data->otype, resultp, 0, p, NULL, NULL, 1);
if (data->sync && !SCHEME_PROCP(data->sync))
scheme_end_in_scheduler();
}
@ -2812,12 +2870,12 @@ void free_cl_cif_queue_args(void *ignored, void *p)
}
if (!SCHEME_PROCP(argv[0]))
scheme_wrong_type(MYNAME, "procedure", 0, argc, argv);
scheme_wrong_contract(MYNAME, "procedure?", 0, argc, argv);
nargs = scheme_proper_list_length(itypes);
if (nargs < 0)
scheme_wrong_type(MYNAME, "proper list", 1, argc, argv);
scheme_wrong_contract(MYNAME, "list?", 1, argc, argv);
if (NULL == (base = get_ctype_base(otype)))
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
scheme_wrong_contract(MYNAME, "ctype?", 2, argc, argv);
rtype = CTYPE_ARG_PRIMTYPE(base);
abi = GET_ABI(MYNAME,3);
is_atomic = ((argc > 4) && SCHEME_TRUEP(argv[4]));
@ -2853,9 +2911,9 @@ void free_cl_cif_queue_args(void *ignored, void *p)
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);
scheme_wrong_contract(MYNAME, "(listof ctype?)", 1, argc, argv);
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv);
wrong_void(MYNAME, SCHEME_CAR(p), 1, 1, argc, argv);
atypes[i] = CTYPE_ARG_PRIMTYPE(base);
}
if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
@ -2926,10 +2984,13 @@ static void save_errno_values(int kind)
@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)))))])
[syms (string-append
"(or/c "
(let loop ([errnos errnos])
(if (null? (cdr errnos))
(format "'~a" (car errnos))
(format "'~a ~a" (car errnos) (loop (cdr errnos)))))
")")])
@list{
if (SCHEME_SYMBOLP(v) && !SCHEME_SYM_WEIRDP(v)) {
@(add-newlines
@ -2939,7 +3000,7 @@ static void save_errno_values(int kind)
return scheme_make_integer(@symbol->string[e]);
}))
}
scheme_wrong_type(MYNAME, "@syms",0, argc, argv);
scheme_wrong_contract(MYNAME, "@syms",0, argc, argv);
return NULL;
})
}
@ -2966,8 +3027,6 @@ static void save_errno_values(int kind)
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);
@ -3007,8 +3066,8 @@ void scheme_init_foreign_globals()
@(cadr sym) = scheme_intern_symbol("@(car sym)")})
(reverse (symbols)))
MZ_REGISTER_STATIC(ffi_name_prefix);
ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:");
MZ_REGISTER_STATIC(ffi_name);
ffi_name = scheme_make_byte_string("ffi:proc");
}
void scheme_init_foreign_places() {

4
src/racket/src/error.c
View File

@ -1388,7 +1388,7 @@ char *scheme_make_arity_expect_string(Scheme_Object *proc,
return make_arity_expect_string(name, namelen, mina, maxa, argc, argv, _slen, 0);
}
char *scheme_make_args_string(char *s, int which, int argc, Scheme_Object **argv, intptr_t *_olen)
char *scheme_make_args_string(const char *s, int which, int argc, Scheme_Object **argv, intptr_t *_olen)
{
char *other;
intptr_t len;
@ -1429,7 +1429,7 @@ char *scheme_make_args_string(char *s, int which, int argc, Scheme_Object **argv
return other;
}
char *scheme_make_arg_lines_string(char *indent, int which, int argc, Scheme_Object **argv, intptr_t *_olen)
char *scheme_make_arg_lines_string(const char *indent, int which, int argc, Scheme_Object **argv, intptr_t *_olen)
{
char *other;
intptr_t len, plen;

4
src/racket/src/schemef.h
View File

@ -1160,8 +1160,8 @@ MZ_EXTERN int scheme_check_proc_arity2(const char *where, int a,
int false_ok);
MZ_EXTERN char *scheme_make_provided_string(Scheme_Object *o, int count, intptr_t *len);
MZ_EXTERN char *scheme_make_args_string(char *s, int which, int argc, Scheme_Object **argv, intptr_t *len);
MZ_EXTERN char *scheme_make_arg_lines_string(char *s, int which, int argc, Scheme_Object **argv, intptr_t *len);
MZ_EXTERN char *scheme_make_args_string(const char *s, int which, int argc, Scheme_Object **argv, intptr_t *len);
MZ_EXTERN char *scheme_make_arg_lines_string(const char *s, int which, int argc, Scheme_Object **argv, intptr_t *len);
MZ_EXTERN const char *scheme_system_library_subpath();

4
src/racket/src/schemex.h
View File

@ -944,8 +944,8 @@ int (*scheme_check_proc_arity2)(const char *where, int a,
int which, int argc, Scheme_Object **argv,
int false_ok);
char *(*scheme_make_provided_string)(Scheme_Object *o, int count, intptr_t *len);
char *(*scheme_make_args_string)(char *s, int which, int argc, Scheme_Object **argv, intptr_t *len);
char *(*scheme_make_arg_lines_string)(char *s, int which, int argc, Scheme_Object **argv, intptr_t *len);
char *(*scheme_make_args_string)(const char *s, int which, int argc, Scheme_Object **argv, intptr_t *len);
char *(*scheme_make_arg_lines_string)(const char *s, int which, int argc, Scheme_Object **argv, intptr_t *len);
const char *(*scheme_system_library_subpath)();
void (*scheme_signal_received)(void);
void (*scheme_signal_received_at)(void *);

3
src/racket/src/schpriv.h
View File

@ -3355,9 +3355,6 @@ const char *scheme_number_suffix(int);
const char *scheme_hostname_error(int err);
char *scheme_make_args_string(char *s, int which, int argc, Scheme_Object **argv, intptr_t *olen);
char *scheme_make_arg_lines_string(char *indent, int which, int argc, Scheme_Object **argv, intptr_t *_olen);
#define IMPROPER_LIST_FORM "illegal use of `.'"
int scheme_byte_string_has_null(Scheme_Object *o);