FFI: add C arrays and unions
This commit is contained in:
Matthew Flatt
parent
994092ea33
commit
345b06838d
|
|
@ -10,7 +10,8 @@
|
|||
cpointer? ptr-equal? ptr-add ptr-ref ptr-set! (protect-out cast)
|
||||
ptr-offset ptr-add! offset-ptr? set-ptr-offset!
|
||||
vector->cpointer flvector->cpointer saved-errno lookup-errno
|
||||
ctype? make-ctype make-cstruct-type make-sized-byte-string ctype->layout
|
||||
ctype? make-ctype make-cstruct-type make-array-type make-union-type
|
||||
make-sized-byte-string ctype->layout
|
||||
_void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
|
||||
_fixint _ufixint _fixnum _ufixnum
|
||||
_float _double _double*
|
||||
|
|
@ -973,6 +974,90 @@
|
|||
[(_ . xs) (_bytes . xs)]
|
||||
[_ _bytes]))
|
||||
|
||||
;; (_array <type> <len> ...+)
|
||||
(provide _array
|
||||
array? array-ptr
|
||||
(protect-out array-ref array-set!))
|
||||
|
||||
(define _array
|
||||
(case-lambda
|
||||
[(t n)
|
||||
(make-ctype (make-array-type t n)
|
||||
(lambda (v) (array-ptr v))
|
||||
(lambda (v) (make-array v t n)))]
|
||||
[(t n . ns)
|
||||
(_array (apply _array t ns) n)]))
|
||||
|
||||
(define-struct array (ptr type len))
|
||||
(define array-ref
|
||||
(case-lambda
|
||||
[(a i)
|
||||
(let ([len (array-len a)])
|
||||
(if (< -1 i len)
|
||||
(ptr-ref (array-ptr a) (array-type a) i)
|
||||
(raise-mismatch-error 'array-ref "index out of bounds: " i)))]
|
||||
[(a . is)
|
||||
(let loop ([a a] [is is])
|
||||
(if (null? is)
|
||||
a
|
||||
(loop (array-ref a (car is)) (cdr is))))]))
|
||||
(define array-set!
|
||||
(case-lambda
|
||||
[(a i v)
|
||||
(let ([len (array-len a)])
|
||||
(if (< -1 i len)
|
||||
(ptr-set! (array-ptr a) (array-type a) i v)
|
||||
(raise-mismatch-error 'array-ref "index out of bounds: " i)))]
|
||||
[(a i i1 . is+v)
|
||||
(let ([is+v (reverse (list* i i1 is+v))])
|
||||
(define v (car is+v))
|
||||
(define i (cadr is+v))
|
||||
(let loop ([a a] [is (cddr is+v)])
|
||||
(if (null? is)
|
||||
(array-set! a i v)
|
||||
(loop (array-ref a (car is)) (cdr is)))))]))
|
||||
|
||||
;; (_array/list <type> <len> ...+)
|
||||
;; Like _list, but for arrays instead of pointers at the C level.
|
||||
(provide _array/list)
|
||||
(define _array/list
|
||||
(case-lambda
|
||||
[(t n)
|
||||
(make-ctype (make-array-type t n)
|
||||
(lambda (v) (list->cblock v t n))
|
||||
(lambda (v) (cblock->list v t n)))]
|
||||
[(t n . ns)
|
||||
(_array/list (apply _array/list t ns) n)]))
|
||||
|
||||
;; (_array/vector <type> <len> ...+)
|
||||
;; Like _vector, but for arrays instead of pointers at the C level.
|
||||
(provide _array/vector)
|
||||
(define _array/vector
|
||||
(case-lambda
|
||||
[(t n)
|
||||
(make-ctype (make-array-type t n)
|
||||
(lambda (v) (vector->cblock v t n))
|
||||
(lambda (v) (cblock->vector v t n)))]
|
||||
[(t n . ns)
|
||||
(_array/vector (apply _array/vector t ns) n)]))
|
||||
|
||||
;; (_union <type> ...+)
|
||||
(provide _union
|
||||
union? union-ptr
|
||||
(protect-out union-ref union-set!))
|
||||
|
||||
(define (_union t . ts)
|
||||
(let ([ts (cons t ts)])
|
||||
(make-ctype (apply make-union-type ts)
|
||||
(lambda (v) (union-ptr v))
|
||||
(lambda (v) (make-union v ts)))))
|
||||
|
||||
(define-struct union (ptr types))
|
||||
(define (union-ref u i)
|
||||
(ptr-ref (union-ptr u) (list-ref (union-types u) i)))
|
||||
(define (union-set! u i v)
|
||||
(ptr-set! (union-ptr u) (list-ref (union-types u) i) v))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; Tagged pointers
|
||||
|
||||
|
|
@ -1418,6 +1503,7 @@
|
|||
(cond
|
||||
[(ctype? b) (ctype->layout b)]
|
||||
[(list? b) (map ctype->layout b)]
|
||||
[(vector? b) (vector (ctype->layout (vector-ref b 0)) (vector-ref b 1))]
|
||||
[else (hash-ref prim-synonyms b b)])))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
|
|
@ -1432,10 +1518,14 @@
|
|||
(values x type))))
|
||||
|
||||
;; Converting Scheme lists to/from C vectors (going back requires a length)
|
||||
(define* (list->cblock l type)
|
||||
(define* (list->cblock l type [need-len #f])
|
||||
(define len (length l))
|
||||
(when need-len
|
||||
(unless (= len need-len)
|
||||
(error 'list->cblock "list does not have the expected length: ~e" l)))
|
||||
(if (null? l)
|
||||
#f ; null => NULL
|
||||
(let ([cblock (malloc (length l) type)])
|
||||
(let ([cblock (malloc len type)])
|
||||
(let loop ([l l] [i 0])
|
||||
(unless (null? l)
|
||||
(ptr-set! cblock type i (car l))
|
||||
|
|
@ -1453,8 +1543,11 @@
|
|||
"expecting a non-void pointer, got ~s" cblock)]))
|
||||
|
||||
;; Converting Scheme vectors to/from C vectors
|
||||
(define* (vector->cblock v type)
|
||||
(define* (vector->cblock v type [need-len #f])
|
||||
(let ([len (vector-length v)])
|
||||
(when need-len
|
||||
(unless (= need-len len)
|
||||
(error 'vector->cblock "vector does not have the expected length: ~e" v)))
|
||||
(if (zero? len)
|
||||
#f ; #() => NULL
|
||||
(let ([cblock (malloc len type)])
|
||||
|
|
|
|||
|
|
@ -62,7 +62,9 @@ type. It can be any of the following symbols:
|
|||
]
|
||||
|
||||
The result can also be a list, which describes a C struct whose
|
||||
element representations are provided in order within the list.}
|
||||
element representations are provided in order within the
|
||||
list. Finally, the result can be a vector of size 2 containing an
|
||||
element representation followed by an exact-integer count.}
|
||||
|
||||
|
||||
@defproc[(compiler-sizeof [sym symbol?]) exact-nonnegative-integer?]{
|
||||
|
|
@ -70,7 +72,7 @@ element representations are provided in order within the list.}
|
|||
Possible values for @racket[symbol] are @racket['int], @racket['char],
|
||||
@racket['short], @racket['long], @racket['*], @racket['void],
|
||||
@racket['float], @racket['double]. The result is the size of the
|
||||
correspond type according to the C @cpp{sizeof} operator for the
|
||||
corresponding type according to the C @cpp{sizeof} operator for the
|
||||
current platform. The @racket[compiler-sizeof] operation should be
|
||||
used to gather information about the current platform, such as
|
||||
defining alias type like @racket[_int] to a known type like
|
||||
|
|
@ -1029,6 +1031,136 @@ expects arguments for both the super fields and the new ones:
|
|||
]}
|
||||
|
||||
|
||||
@; ------------------------------------------------------------
|
||||
|
||||
@section{C Array Types}
|
||||
|
||||
@defproc[(make-array-type [type ctype?]
|
||||
[count exact-nonnegative-integer?])
|
||||
ctype?]{
|
||||
|
||||
The primitive type constructor for creating new C array types. Like C
|
||||
struct types, array types are new primitive types with no conversion
|
||||
functions associated. When used as a function argument or return type,
|
||||
array types behave like pointer types; otherwise, array types behave
|
||||
like struct types (i.e., a struct with as many fields as the array has
|
||||
elements), particularly when used for a field within a struct type.
|
||||
|
||||
Since an array is treated like a struct, @racket[cast]ing a
|
||||
pointer type to an array type does not work. Instead, use
|
||||
@racket[ptr-ref] with a pointer, an array type constructed with
|
||||
@racket[_array], and index @racket[0] to convert a pointer to a Racket
|
||||
representation that works with @racket[array-ref] and
|
||||
@racket[array-set!].}
|
||||
|
||||
|
||||
@defproc[(_array [type ctype?] [count exact-nonnegative-integer?] ...+)
|
||||
ctype?]{
|
||||
|
||||
Creates an array type whose Racket representation is an array that
|
||||
works with @racket[array-ref] and @racket[array-set!]. The array is
|
||||
not copied; the Racket representation is backed by the underlying C
|
||||
representation.
|
||||
|
||||
Supply multiple @racket[count]s for a multidimensional array. Since C
|
||||
uses row-major order for arrays, @racket[(_array _t _n _m)] is
|
||||
equivalent to @racket[(_array (_array _t _m) _n)], which is different
|
||||
from an array of pointers to arrays.}
|
||||
|
||||
|
||||
@defproc[(array? [v any/c]) boolean?]{
|
||||
|
||||
Returns @racket[#t] if @racket[v] is a Racket representation of a C
|
||||
value via @racket[_array], @racket[#f] otherwise.}
|
||||
|
||||
|
||||
@defproc[(array-ref [a array?] [i exact-nonnegative-integer?] ...+)
|
||||
any/c]{
|
||||
|
||||
Extracts an element from an array. Use multiple @racket[i] indices for
|
||||
a multidimensional array access; using fewer indices than the array
|
||||
dimension produces a sub-array.}
|
||||
|
||||
|
||||
@defproc[(array-set! [a array?]
|
||||
[i exact-nonnegative-integer?] ...+
|
||||
[v any/c])
|
||||
void?]{
|
||||
|
||||
Sets an element in an array. Use multiple @racket[i] indices for a
|
||||
multidimensional array update; using fewer indices than the array
|
||||
dimension sets a sub-array (i.e., @racket[v] must be an array of the
|
||||
same size as the sub-array and @racket[v] is copied into the
|
||||
sub-array).}
|
||||
|
||||
|
||||
@defproc[(array-ptr [a array?]) cpointer?]{
|
||||
|
||||
Extracts the pointer for an array's storage.}
|
||||
|
||||
|
||||
@defproc[(_array/list [type ctype?] [count exact-nonnegative-integer?] ...+)
|
||||
ctype?]{
|
||||
|
||||
Like @racket[_array], but the Racket representation is a list (or list
|
||||
of lists for a multidimensional array) of elements copied to and from
|
||||
an underlying C array.}
|
||||
|
||||
|
||||
@defproc[(_array/vector [type ctype?] [count exact-nonnegative-integer?] ...+)
|
||||
ctype?]{
|
||||
|
||||
Like @racket[_array], but the Racket representation is a vector (or
|
||||
vector of vectors for a multidimensional array) of elements copied to
|
||||
and from an underlying C array.}
|
||||
|
||||
|
||||
@; ------------------------------------------------------------
|
||||
|
||||
@section{C Union Types}
|
||||
|
||||
@defproc[(make-union-type [type ctype?] ...+)
|
||||
ctype?]{
|
||||
|
||||
The primitive type constructor for creating new C union types. Like C
|
||||
struct types, union types are new primitive types with no conversion
|
||||
functions associated. Unions are always treated like structs.}
|
||||
|
||||
|
||||
@defproc[(_union [type ctype?] ...+)
|
||||
ctype?]{
|
||||
|
||||
Creates a union type whose Racket representation is a union that
|
||||
works with @racket[union-ref] and @racket[union-set!]. The union is
|
||||
not copied; the Racket representation is backed by the underlying C
|
||||
representation.}
|
||||
|
||||
|
||||
@defproc[(union? [v any/c]) boolean?]{
|
||||
|
||||
Returns @racket[#t] if @racket[v] is a Racket representation of a C
|
||||
value via @racket[_union], @racket[#f] otherwise.}
|
||||
|
||||
|
||||
@defproc[(union-ref [u union?] [i exact-nonnegative-integer?])
|
||||
any/c]{
|
||||
|
||||
Extracts a variant from a union.}
|
||||
|
||||
|
||||
@defproc[(union-set! [u union?]
|
||||
[i exact-nonnegative-integer?]
|
||||
[v any/c])
|
||||
void?]{
|
||||
|
||||
Sets a variant in a union..}
|
||||
|
||||
|
||||
@defproc[(union-ptr [u array?]) cpointer?]{
|
||||
|
||||
Extracts the pointer for a union's storage.}
|
||||
|
||||
|
||||
@; ------------------------------------------------------------
|
||||
|
||||
@section{Enumerations and Masks}
|
||||
|
|
|
|||
|
|
@ -78,3 +78,125 @@ X char_int charint_swap(char_int x) {
|
|||
int(*grabbed_callback)(int) = NULL;
|
||||
X void grab_callback(int(*f)(int)) { grabbed_callback = f; }
|
||||
X int use_grabbed_callback(int n) { return grabbed_callback(n); }
|
||||
|
||||
typedef char c7_array[7];
|
||||
|
||||
X char* increment_c_array(c7_array c) {
|
||||
int i;
|
||||
for (i = 0; i < 7; i++)
|
||||
c[i]++;
|
||||
return c;
|
||||
}
|
||||
|
||||
struct char7 {
|
||||
char c[7];
|
||||
};
|
||||
struct int_char7_int {
|
||||
int i1;
|
||||
struct char7 c7;
|
||||
int i2;
|
||||
};
|
||||
|
||||
X struct int_char7_int increment_ic7i(struct int_char7_int v)
|
||||
{
|
||||
int i;
|
||||
|
||||
v.i1++;
|
||||
for (i = 0; i < 7; i++)
|
||||
v.c7.c[i]++;
|
||||
v.i2++;
|
||||
|
||||
return v;
|
||||
}
|
||||
|
||||
X struct int_char7_int ic7i_cb(struct int_char7_int v,
|
||||
struct int_char7_int (*cb)(struct int_char7_int))
|
||||
{
|
||||
int i;
|
||||
|
||||
--v.i1;
|
||||
for (i = 0; i < 7; i++)
|
||||
--v.c7.c[i];
|
||||
--v.i2;
|
||||
|
||||
v = cb(v);
|
||||
|
||||
v.i1++;
|
||||
for (i = 0; i < 7; i++)
|
||||
v.c7.c[i]++;
|
||||
v.i2++;
|
||||
|
||||
return v;
|
||||
}
|
||||
|
||||
X char* increment_2d_array(char c[3][7]) {
|
||||
int i, j;
|
||||
for (i = 0; i < 7; i++) {
|
||||
for (j = 0; j < 3; j++) {
|
||||
c[j][i] += (i + j);
|
||||
}
|
||||
}
|
||||
return (char *)c;
|
||||
}
|
||||
|
||||
X int with_2d_array_cb(void (*cb)(char c[3][7]))
|
||||
{
|
||||
char c[3][7];
|
||||
int i, j, r;
|
||||
|
||||
for (i = 0; i < 3; i++) {
|
||||
for (j = 0; j < 7; j++) {
|
||||
c[i][j] = (i + (2 * j));
|
||||
}
|
||||
}
|
||||
|
||||
cb(c);
|
||||
|
||||
r = 0;
|
||||
for (i = 0; i < 3; i++) {
|
||||
for (j = 0; j < 7; j++) {
|
||||
r += (c[i][j] - ((2 * i) + (2 * j)));
|
||||
}
|
||||
}
|
||||
|
||||
return r;
|
||||
}
|
||||
|
||||
union borl {
|
||||
char b;
|
||||
long l;
|
||||
};
|
||||
|
||||
X union borl increment_borl(int which, union borl v)
|
||||
{
|
||||
int i;
|
||||
|
||||
if (which) {
|
||||
v.l++;
|
||||
} else {
|
||||
v.b++;
|
||||
}
|
||||
|
||||
return v;
|
||||
}
|
||||
|
||||
union ic7iorl {
|
||||
struct int_char7_int ic7i;
|
||||
long l;
|
||||
};
|
||||
|
||||
X union ic7iorl increment_ic7iorl(int which, union ic7iorl v)
|
||||
{
|
||||
int i;
|
||||
|
||||
if (which) {
|
||||
v.l++;
|
||||
} else {
|
||||
v.ic7i.i1++;
|
||||
for (i = 0; i < 7; i++)
|
||||
v.ic7i.c7.c[i]++;
|
||||
v.ic7i.i2++;
|
||||
}
|
||||
|
||||
return v;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -52,6 +52,20 @@
|
|||
(when (file-exists? o) (delete-file o))
|
||||
(when (file-exists? so) (delete-file so)))))
|
||||
|
||||
;; Test arrays
|
||||
(define _c7_list (_array/list _byte 7))
|
||||
(test 7 ctype-sizeof _c7_list)
|
||||
(test 1 ctype-alignof _c7_list)
|
||||
|
||||
(test 21 ctype-sizeof (_array _byte 3 7))
|
||||
|
||||
(define-cstruct _ic7i ([i1 _int]
|
||||
[c7 _c7_list]
|
||||
[i2 _int]))
|
||||
|
||||
(define _borl (_union _byte _long))
|
||||
(define _ic7iorl (_union _ic7i _long))
|
||||
|
||||
(define test-lib (ffi-lib "./foreign-test"))
|
||||
|
||||
(for ([n (in-range 5)])
|
||||
|
|
@ -173,6 +187,82 @@
|
|||
(test '(1 2)
|
||||
(get-ffi-obj 'scheme_make_pair #f (_fun _scheme _scheme -> _scheme))
|
||||
1 '(2))
|
||||
;; ---
|
||||
;; test arrays
|
||||
(let ([p (malloc _c7_list)]) ;; should allocate the right size
|
||||
(for ([i 7]) (ptr-set! p _byte i (+ i 10)))
|
||||
(test (for/list ([i 7]) (+ i 10)) cast p _pointer (_list o _byte 7))
|
||||
(t (for/list ([i 7]) (+ i 11)) 'increment_c_array (_fun _pointer -> (_list o _byte 7)) p)
|
||||
(let ([a (ptr-ref p (_array _byte 7))])
|
||||
(test 12 array-ref a 1)
|
||||
(ptr-set! p _byte 1 17)
|
||||
(test 17 array-ref a 1)))
|
||||
(let ([v (for/list ([i 7]) i)])
|
||||
;; pass array as pointer:
|
||||
;; FIXME: these tests wrap the result pointer as non-GCable,
|
||||
;; but _c7_list allocates the argument array as GCable.
|
||||
(t (for/list ([i 7]) (add1 i)) 'increment_c_array (_fun _c7_list -> (_list o _byte 7)) v)
|
||||
(t (for/list ([i 7]) (add1 i)) 'increment_c_array (_fun _c7_list -> _c7_list) v)
|
||||
(let ([r ((ffi 'increment_c_array (_fun _c7_list -> (_array _byte 7))) v)])
|
||||
(test 2 array-ref r 1))
|
||||
;; Array within struct argument and result:
|
||||
(let* ([ic7i (make-ic7i 13 v 14)]
|
||||
[ic7i-2 ((ffi 'increment_ic7i (_fun _ic7i -> _ic7i)) ic7i)])
|
||||
(test v ptr-ref (cast ic7i _ic7i-pointer _pointer) _c7_list 'abs (ctype-sizeof _int))
|
||||
(test 13 ic7i-i1 ic7i)
|
||||
(test v ic7i-c7 ic7i)
|
||||
(test 14 ic7i-i2 ic7i)
|
||||
(test 14 ic7i-i1 ic7i-2)
|
||||
(test (map add1 v) ic7i-c7 ic7i-2)
|
||||
(test 15 ic7i-i2 ic7i-2)
|
||||
(let ([ic7i-3 ((ffi 'ic7i_cb (_fun _ic7i (_fun _ic7i -> _ic7i) -> _ic7i))
|
||||
ic7i
|
||||
(lambda (ic7i-4)
|
||||
(test 12 ic7i-i1 ic7i-4)
|
||||
(test (cons 255 (map sub1 (cdr v))) ic7i-c7 ic7i-4)
|
||||
(test 13 ic7i-i2 ic7i-4)
|
||||
(make-ic7i 2 (map (lambda (x) (- 252 x)) v) 9)))])
|
||||
(test 3 ic7i-i1 ic7i-3)
|
||||
(test (map add1 (map (lambda (x) (- 252 x)) v)) ic7i-c7 ic7i-3)
|
||||
(test 10 ic7i-i2 ic7i-3))))
|
||||
;; Two-dimensional array:
|
||||
;; FIXME: same allocation bug for result as above
|
||||
(let ([v (for/list ([j 3]) (for/list ([i 7]) (+ i j)))]
|
||||
[v2 (for*/vector ([j 3] [i 7]) (+ i i j j))]
|
||||
[v3 (for/vector ([j 3]) (for/vector ([i 7]) (+ i i j j)))])
|
||||
(t v2 'increment_2d_array (_fun (_array/list _byte 3 7) -> (_vector o _byte 21)) v)
|
||||
(t v2 'increment_2d_array (_fun (_array/list (_array/list _byte 7) 3) -> (_vector o _byte 21)) v)
|
||||
(t v3 'increment_2d_array (_fun (_array/list (_array/list _byte 7) 3) -> (_array/vector _byte 3 7)) v))
|
||||
(t 0 'with_2d_array_cb (_fun (_fun (_array _byte 3 7) -> _void) -> _int)
|
||||
(lambda (a) (for ([i 3])
|
||||
(for ([j 7])
|
||||
(test (+ i (* 2 j)) array-ref a i j)
|
||||
(array-set! a i j (+ (* 2 i) (* 2 j)))))))
|
||||
;; ---
|
||||
;; test union
|
||||
(let ([u (ptr-ref (malloc _borl) _borl)])
|
||||
(union-set! u 0 190)
|
||||
(test 190 union-ref u 0)
|
||||
(let ([u2 ((ffi 'increment_borl (_fun _int _borl -> _borl)) 0 u)])
|
||||
(test 191 union-ref u2 0))
|
||||
(union-set! u 1 (expt 2 19))
|
||||
(test (expt 2 19) union-ref u 1)
|
||||
(let ([u2 ((ffi 'increment_borl (_fun _int _borl -> _borl)) 1 u)])
|
||||
(test (add1 (expt 2 19)) union-ref u2 1)))
|
||||
(let ([u (ptr-ref (malloc _ic7iorl) _ic7iorl)])
|
||||
(union-set! u 1 190)
|
||||
(test 190 union-ref u 1)
|
||||
(let ([u2 ((ffi 'increment_ic7iorl (_fun _int _ic7iorl -> _ic7iorl)) 1 u)])
|
||||
(test 191 union-ref u2 1))
|
||||
(let ([v (for/list ([i 7]) i)])
|
||||
(union-set! u 0 (make-ic7i 3 v 88))
|
||||
(test 3 ic7i-i1 (union-ref u 0))
|
||||
(set-ic7i-i1! (union-ref u 0) 9)
|
||||
(test 9 ic7i-i1 (union-ref u 0))
|
||||
(let ([u2 ((ffi 'increment_ic7iorl (_fun _int _ic7iorl -> _ic7iorl)) 0 u)])
|
||||
(test 10 ic7i-i1 (union-ref u2 0))
|
||||
(test 89 ic7i-i2 (union-ref u2 0))
|
||||
(test (map add1 v) ic7i-c7 (union-ref u2 0)))))
|
||||
)
|
||||
|
||||
;; test setting vector elements
|
||||
|
|
|
|||
|
|
@ -847,6 +847,8 @@ typedef union _ForeignAny {
|
|||
|
||||
/* This is a tag that is used to identify user-made struct types. */
|
||||
#define FOREIGN_struct (27)
|
||||
#define FOREIGN_array (28)
|
||||
#define FOREIGN_union (29)
|
||||
|
||||
static int is_gcable_pointer(Scheme_Object *o) {
|
||||
return !SCHEME_CPTRP(o)
|
||||
|
|
@ -915,6 +917,8 @@ static ffi_type ffi_type_gcpointer;
|
|||
#define CTYPE_USER_S2C(x) (((ctype_struct*)(x))->scheme_to_c)
|
||||
#define CTYPE_USER_C2S(x) (((ctype_struct*)(x))->c_to_scheme)
|
||||
|
||||
#define CTYPE_ARG_PRIMTYPE(x) ((CTYPE_PRIMLABEL(x) == FOREIGN_array) ? &ffi_type_pointer : CTYPE_PRIMTYPE(x))
|
||||
|
||||
/* Returns #f for primitive types. */
|
||||
#define MYNAME "ctype-basetype"
|
||||
static Scheme_Object *foreign_ctype_basetype(int argc, Scheme_Object *argv[])
|
||||
|
|
@ -985,7 +989,7 @@ static int ctype_sizeof(Scheme_Object *type)
|
|||
case FOREIGN_gcpointer: return sizeof(void*);
|
||||
case FOREIGN_scheme: return sizeof(Scheme_Object*);
|
||||
case FOREIGN_fpointer: return sizeof(void*);
|
||||
/* for structs */
|
||||
/* for structs and arrays */
|
||||
default: return CTYPE_PRIMTYPE(type)->size;
|
||||
}
|
||||
}
|
||||
|
|
@ -1144,6 +1148,138 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
|
|||
}
|
||||
#undef MYNAME
|
||||
|
||||
/*****************************************************************************/
|
||||
/* array types */
|
||||
|
||||
/* (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
|
||||
* a struct or for allocation. Marshaling to lists or whatever should
|
||||
* be done in Scheme. */
|
||||
#define MYNAME "make-array-type"
|
||||
static Scheme_Object *foreign_make_array_type(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
Scheme_Object *base, *basetype;
|
||||
GC_CAN_IGNORE ffi_type *libffi_type, **elements;
|
||||
ctype_struct *type;
|
||||
intptr_t len;
|
||||
|
||||
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);
|
||||
|
||||
/* 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
|
||||
an array appears as a struct field. If the array size is 4 or
|
||||
less, or if the total size is 32 bytes or less, then we make a
|
||||
full `elements' array, because the x86_64 ABI always shifts
|
||||
to memory mode after 32 bytes. */
|
||||
|
||||
/* Allocate the new libffi type object, which is only provided to
|
||||
libffi as a type for a structure field. When a FOREIGN_array
|
||||
type is used for a function argument or result, it is replaced
|
||||
with FOREIGN_pointer. We put FFI_TYPE_STRUCT in
|
||||
libffi_type->type and make an elements array that contains
|
||||
a single instance of the element type... which seems to work
|
||||
ok so far. */
|
||||
libffi_type = malloc(sizeof(ffi_type));
|
||||
libffi_type->size = CTYPE_PRIMTYPE(base)->size * len;
|
||||
libffi_type->alignment = CTYPE_PRIMTYPE(base)->alignment;
|
||||
libffi_type->type = FFI_TYPE_STRUCT;
|
||||
|
||||
if ((libffi_type->size <= 32) || (len <= 4)) {
|
||||
int i;
|
||||
elements = malloc((len + 1) * sizeof(ffi_type*));
|
||||
for (i = 0; i < len; i++) {
|
||||
elements[i] = CTYPE_PRIMTYPE(base);
|
||||
}
|
||||
elements[len] = NULL;
|
||||
} else {
|
||||
elements = malloc(2 * sizeof(ffi_type*));
|
||||
elements[0] = CTYPE_PRIMTYPE(base);
|
||||
elements[1] = NULL;
|
||||
}
|
||||
libffi_type->elements = elements;
|
||||
|
||||
basetype = scheme_make_vector(2, argv[0]);
|
||||
SCHEME_VEC_ELS(basetype)[1] = argv[1];
|
||||
|
||||
type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
|
||||
type->so.type = ctype_tag;
|
||||
type->basetype = (basetype);
|
||||
type->scheme_to_c = ((Scheme_Object*)libffi_type);
|
||||
type->c_to_scheme = ((Scheme_Object*)FOREIGN_array);
|
||||
|
||||
scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
|
||||
|
||||
return (Scheme_Object*)type;
|
||||
}
|
||||
#undef MYNAME
|
||||
|
||||
/*****************************************************************************/
|
||||
/* union types */
|
||||
|
||||
/* (make-union-type type ...+) -> ctype */
|
||||
/* This creates a new primitive type that is a union. All unions
|
||||
* behave like structs. Marshaling to lists or whatever should
|
||||
* be done in Scheme. */
|
||||
#define MYNAME "make-union-type"
|
||||
static Scheme_Object *foreign_make_union_type(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
Scheme_Object *base, *basetype;
|
||||
GC_CAN_IGNORE ffi_type *libffi_type, **elements;
|
||||
ctype_struct *type;
|
||||
int i, align = 1, a, sz = 0;
|
||||
|
||||
elements = malloc((argc + 1) * sizeof(ffi_type*));
|
||||
|
||||
/* find max required alignment and size: */
|
||||
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);
|
||||
}
|
||||
a = CTYPE_PRIMTYPE(base)->alignment;
|
||||
if (a > align) align = a;
|
||||
a = CTYPE_PRIMTYPE(base)->size;
|
||||
if (sz < a) sz = a;
|
||||
elements[i] = CTYPE_PRIMTYPE(base);
|
||||
}
|
||||
|
||||
elements[argc] = NULL;
|
||||
|
||||
/* round size up to alignment: */
|
||||
if ((sz % align) != 0) {
|
||||
sz += (align - (sz % align));
|
||||
}
|
||||
|
||||
/* libffi doesn't seem to support union types, but we try to make
|
||||
libffi work anyway by making a structure type. We put all the
|
||||
element types in the `elements' array, because their shapes may
|
||||
affect argument passing. */
|
||||
|
||||
/* Allocate the new libffi type object. */
|
||||
libffi_type = malloc(sizeof(ffi_type));
|
||||
libffi_type->size = sz;
|
||||
libffi_type->alignment = align;
|
||||
libffi_type->type = FFI_TYPE_STRUCT;
|
||||
libffi_type->elements = elements;
|
||||
|
||||
basetype = scheme_box(scheme_build_list(argc, argv));
|
||||
|
||||
type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
|
||||
type->so.type = ctype_tag;
|
||||
type->basetype = (basetype);
|
||||
type->scheme_to_c = ((Scheme_Object*)libffi_type);
|
||||
type->c_to_scheme = ((Scheme_Object*)FOREIGN_union);
|
||||
|
||||
scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
|
||||
|
||||
return (Scheme_Object*)type;
|
||||
}
|
||||
#undef MYNAME
|
||||
|
||||
/*****************************************************************************/
|
||||
/* Callback type */
|
||||
|
||||
|
|
@ -1320,6 +1456,8 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
|
|||
case FOREIGN_scheme: return REF_CTYPE(Scheme_Object*);
|
||||
case FOREIGN_fpointer: return (REF_CTYPE(void*));
|
||||
case FOREIGN_struct:
|
||||
case FOREIGN_array:
|
||||
case FOREIGN_union:
|
||||
if (gcsrc)
|
||||
return scheme_make_foreign_offset_cpointer(src, delta);
|
||||
else
|
||||
|
|
@ -1338,9 +1476,9 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
|
|||
* ptr */
|
||||
|
||||
/* Usually writes the C object to dst and returns NULL. When basetype_p is not
|
||||
* NULL, then any pointer value (any pointer or a struct) is returned, and the
|
||||
* 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 value will be *copied* into dst. */
|
||||
* then a struct or array value will be *copied* into dst. */
|
||||
static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
|
||||
Scheme_Object *val, intptr_t *basetype_p, intptr_t *_offset,
|
||||
int ret_loc)
|
||||
|
|
@ -1740,6 +1878,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
|
|||
if (!(ret_loc)) scheme_wrong_type("Scheme->C","fpointer",0,1,&(val));
|
||||
break;
|
||||
case FOREIGN_struct:
|
||||
case FOREIGN_array:
|
||||
case FOREIGN_union:
|
||||
if (!SCHEME_FFIANYPTRP(val))
|
||||
scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);
|
||||
{
|
||||
|
|
@ -1752,7 +1892,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
|
|||
CTYPE_PRIMTYPE(type)->size);
|
||||
return NULL;
|
||||
} else {
|
||||
*basetype_p = FOREIGN_struct;
|
||||
*basetype_p = CTYPE_PRIMLABEL(type);
|
||||
if (_offset && is_gcable_pointer(val)) {
|
||||
*_offset = poff;
|
||||
return p;
|
||||
|
|
@ -2559,7 +2699,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
* be ignored by the GC is avalues.)
|
||||
*/
|
||||
GC_CAN_IGNORE ForeignAny *ivals, oval;
|
||||
void **avalues, *p, *newp, *tmp;
|
||||
void **avalues, *p, *newp;
|
||||
GC_CAN_IGNORE ForeignAny stack_ivals[MAX_QUICK_ARGS];
|
||||
void *stack_avalues[MAX_QUICK_ARGS];
|
||||
intptr_t stack_offsets[MAX_QUICK_ARGS];
|
||||
|
|
@ -2592,7 +2732,8 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
/* If this is a struct return value, then need to malloc in any case, even if
|
||||
* the size is smaller than ForeignAny, because this value will be
|
||||
* returned. */
|
||||
if (CTYPE_PRIMLABEL(base) == FOREIGN_struct) {
|
||||
if ((CTYPE_PRIMLABEL(base) == FOREIGN_struct)
|
||||
|| (CTYPE_PRIMLABEL(base) == FOREIGN_union)) {
|
||||
/* need to have p be a pointer that is invisible to the GC */
|
||||
p = malloc(CTYPE_PRIMTYPE(base)->size);
|
||||
newp = scheme_malloc_atomic(CTYPE_PRIMTYPE(base)->size);
|
||||
|
|
@ -2605,7 +2746,8 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
for (i=0; i<nargs; i++) {
|
||||
if ((avalues[i] == NULL) && !offsets[i]) /* if this was a non-pointer... */
|
||||
avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
|
||||
else if (ivals[i].x_fixnum != FOREIGN_struct) { /* if *not* a struct... */
|
||||
else if ((ivals[i].x_fixnum != FOREIGN_struct)
|
||||
&& (ivals[i].x_fixnum != FOREIGN_union)) { /* if *not* a struct... */
|
||||
/* ... set the ivals pointer (pointer type doesn't matter) and avalues */
|
||||
ivals[i].x_pointer = avalues[i];
|
||||
avalues[i] = &(ivals[i]);
|
||||
|
|
@ -2633,16 +2775,15 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
avalues = NULL;
|
||||
switch (CTYPE_PRIMLABEL(base)) {
|
||||
case FOREIGN_struct:
|
||||
case FOREIGN_union:
|
||||
memcpy(newp, p, CTYPE_PRIMTYPE(base)->size);
|
||||
free(p);
|
||||
p = newp;
|
||||
break;
|
||||
default:
|
||||
/* not sure why this code is here, looks fine to remove this case */
|
||||
if (CTYPE_PRIMTYPE(base) == &ffi_type_pointer) {
|
||||
tmp = ((void**)p)[0];
|
||||
p = &tmp;
|
||||
}
|
||||
case FOREIGN_array:
|
||||
/* array as result is treated as a pointer, so
|
||||
adjust `p' to make C2SCHEME work right */
|
||||
p = *(void **)p;
|
||||
break;
|
||||
}
|
||||
return C2SCHEME(otype, p, 0, 1, 1);
|
||||
|
|
@ -2689,7 +2830,7 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
|
|||
scheme_wrong_type(MYNAME, "proper list", 1, argc, argv);
|
||||
if (NULL == (base = get_ctype_base(otype)))
|
||||
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
|
||||
rtype = CTYPE_PRIMTYPE(base);
|
||||
rtype = CTYPE_ARG_PRIMTYPE(base);
|
||||
abi = GET_ABI(MYNAME,3);
|
||||
if (argc > 4) {
|
||||
save_errno = -1;
|
||||
|
|
@ -2719,7 +2860,7 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
|
|||
scheme_wrong_type(MYNAME, "list-of-C-types", 1, argc, argv);
|
||||
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
|
||||
scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv);
|
||||
atypes[i] = CTYPE_PRIMTYPE(base);
|
||||
atypes[i] = CTYPE_ARG_PRIMTYPE(base);
|
||||
}
|
||||
cif = malloc(sizeof(ffi_cif));
|
||||
if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
|
||||
|
|
@ -2776,7 +2917,7 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
|
|||
ffi_callback_struct *data;
|
||||
Scheme_Object *argv_stack[MAX_QUICK_ARGS];
|
||||
int argc = cif->nargs, i;
|
||||
Scheme_Object **argv, *p, *v;
|
||||
Scheme_Object **argv, *p, *v, *t;
|
||||
|
||||
data = extract_ffi_callback(userdata);
|
||||
|
||||
|
|
@ -2787,7 +2928,12 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
|
|||
if (data->sync && !SCHEME_PROCP(data->sync))
|
||||
scheme_start_in_scheduler();
|
||||
for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
|
||||
v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0, 0);
|
||||
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);
|
||||
} else
|
||||
v = C2SCHEME(t, args[i], 0, 0, 0);
|
||||
argv[i] = v;
|
||||
}
|
||||
p = _scheme_apply(data->proc, argc, argv);
|
||||
|
|
@ -3035,7 +3181,7 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[])
|
|||
scheme_wrong_type(MYNAME, "proper list", 1, argc, argv);
|
||||
if (NULL == (base = get_ctype_base(otype)))
|
||||
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
|
||||
rtype = CTYPE_PRIMTYPE(base);
|
||||
rtype = CTYPE_ARG_PRIMTYPE(base);
|
||||
abi = GET_ABI(MYNAME,3);
|
||||
is_atomic = ((argc > 4) && SCHEME_TRUEP(argv[4]));
|
||||
sync = (is_atomic ? scheme_true : NULL);
|
||||
|
|
@ -3072,7 +3218,7 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[])
|
|||
scheme_wrong_type(MYNAME, "list-of-C-types", 1, argc, argv);
|
||||
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
|
||||
scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv);
|
||||
atypes[i] = CTYPE_PRIMTYPE(base);
|
||||
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");
|
||||
|
|
@ -3303,6 +3449,10 @@ void scheme_init_foreign(Scheme_Env *env)
|
|||
scheme_make_prim_w_arity(foreign_make_ctype, "make-ctype", 3, 3), menv);
|
||||
scheme_add_global("make-cstruct-type",
|
||||
scheme_make_prim_w_arity(foreign_make_cstruct_type, "make-cstruct-type", 1, 3), menv);
|
||||
scheme_add_global("make-array-type",
|
||||
scheme_make_prim_w_arity(foreign_make_array_type, "make-array-type", 2, 2), menv);
|
||||
scheme_add_global("make-union-type",
|
||||
scheme_make_prim_w_arity(foreign_make_union_type, "make-union-type", 1, -1), menv);
|
||||
scheme_add_global("ffi-callback?",
|
||||
scheme_make_prim_w_arity(foreign_ffi_callback_p, "ffi-callback?", 1, 1), menv);
|
||||
scheme_add_global("cpointer?",
|
||||
|
|
@ -3612,6 +3762,10 @@ void scheme_init_foreign(Scheme_Env *env)
|
|||
scheme_make_prim_w_arity((Scheme_Prim *)foreign_make_ctype, "make-ctype", 3, 3), menv);
|
||||
scheme_add_global("make-cstruct-type",
|
||||
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-cstruct-type", 1, 3), menv);
|
||||
scheme_add_global("make-array-type",
|
||||
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-array-type", 2, 2), menv);
|
||||
scheme_add_global("make-union-type",
|
||||
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-union-type", 1, -1), menv);
|
||||
scheme_add_global("ffi-callback?",
|
||||
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-callback?", 1, 1), menv);
|
||||
scheme_add_global("cpointer?",
|
||||
|
|
|
|||
|
|
@ -754,7 +754,9 @@ typedef union _ForeignAny {
|
|||
|
||||
/* This is a tag that is used to identify user-made struct types. */
|
||||
@; last makes sure this is the last one value that gets used
|
||||
#define FOREIGN_struct (@(type-counter 'last))
|
||||
#define FOREIGN_struct (@(type-counter))
|
||||
#define FOREIGN_array (@(type-counter))
|
||||
#define FOREIGN_union (@(type-counter 'last))
|
||||
|
||||
static int is_gcable_pointer(Scheme_Object *o) {
|
||||
return !SCHEME_CPTRP(o)
|
||||
|
|
@ -790,6 +792,8 @@ static ffi_type ffi_type_gcpointer;
|
|||
#define CTYPE_USER_S2C(x) (((ctype_struct*)(x))->scheme_to_c)
|
||||
#define CTYPE_USER_C2S(x) (((ctype_struct*)(x))->c_to_scheme)
|
||||
|
||||
#define CTYPE_ARG_PRIMTYPE(x) ((CTYPE_PRIMLABEL(x) == FOREIGN_array) ? &ffi_type_pointer : CTYPE_PRIMTYPE(x))
|
||||
|
||||
/* Returns #f for primitive types. */
|
||||
@cdefine[ctype-basetype 1]{
|
||||
if (!SCHEME_CTYPEP(argv[0]))
|
||||
|
|
@ -827,7 +831,7 @@ static int ctype_sizeof(Scheme_Object *type)
|
|||
switch (CTYPE_PRIMLABEL(type)) {
|
||||
@(map-types @list{case FOREIGN_@|cname|: @;
|
||||
return @(if ctype @list{sizeof(@ctype)} "0")})
|
||||
/* for structs */
|
||||
/* for structs and arrays */
|
||||
default: return CTYPE_PRIMTYPE(type)->size;
|
||||
}
|
||||
}
|
||||
|
|
@ -972,6 +976,128 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
|
|||
return (Scheme_Object*)type;
|
||||
}
|
||||
|
||||
/*****************************************************************************/
|
||||
/* array types */
|
||||
|
||||
/* (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
|
||||
* a struct or for allocation. Marshaling to lists or whatever should
|
||||
* be done in Scheme. */
|
||||
@cdefine[make-array-type 2 2]{
|
||||
Scheme_Object *base, *basetype;
|
||||
GC_CAN_IGNORE ffi_type *libffi_type, **elements;
|
||||
ctype_struct *type;
|
||||
intptr_t len;
|
||||
|
||||
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);
|
||||
|
||||
/* 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
|
||||
an array appears as a struct field. If the array size is 4 or
|
||||
less, or if the total size is 32 bytes or less, then we make a
|
||||
full `elements' array, because the x86_64 ABI always shifts
|
||||
to memory mode after 32 bytes. */
|
||||
|
||||
/* Allocate the new libffi type object, which is only provided to
|
||||
libffi as a type for a structure field. When a FOREIGN_array
|
||||
type is used for a function argument or result, it is replaced
|
||||
with FOREIGN_pointer. We put FFI_TYPE_STRUCT in
|
||||
libffi_type->type and make an elements array that contains
|
||||
a single instance of the element type... which seems to work
|
||||
ok so far. */
|
||||
libffi_type = malloc(sizeof(ffi_type));
|
||||
libffi_type->size = CTYPE_PRIMTYPE(base)->size * len;
|
||||
libffi_type->alignment = CTYPE_PRIMTYPE(base)->alignment;
|
||||
libffi_type->type = FFI_TYPE_STRUCT;
|
||||
|
||||
if ((libffi_type->size <= 32) || (len <= 4)) {
|
||||
int i;
|
||||
elements = malloc((len + 1) * sizeof(ffi_type*));
|
||||
for (i = 0; i < len; i++) {
|
||||
elements[i] = CTYPE_PRIMTYPE(base);
|
||||
}
|
||||
elements[len] = NULL;
|
||||
} else {
|
||||
elements = malloc(2 * sizeof(ffi_type*));
|
||||
elements[0] = CTYPE_PRIMTYPE(base);
|
||||
elements[1] = NULL;
|
||||
}
|
||||
libffi_type->elements = elements;
|
||||
|
||||
basetype = scheme_make_vector(2, argv[0]);
|
||||
SCHEME_VEC_ELS(basetype)[1] = argv[1];
|
||||
|
||||
@cmake["type" ctype "basetype"
|
||||
"(Scheme_Object*)libffi_type"
|
||||
"(Scheme_Object*)FOREIGN_array"]
|
||||
|
||||
scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
|
||||
|
||||
return (Scheme_Object*)type;
|
||||
}
|
||||
|
||||
/*****************************************************************************/
|
||||
/* union types */
|
||||
|
||||
/* (make-union-type type ...+) -> ctype */
|
||||
/* This creates a new primitive type that is a union. All unions
|
||||
* behave like structs. Marshaling to lists or whatever should
|
||||
* be done in Scheme. */
|
||||
@cdefine[make-union-type 1 -1]{
|
||||
Scheme_Object *base, *basetype;
|
||||
GC_CAN_IGNORE ffi_type *libffi_type, **elements;
|
||||
ctype_struct *type;
|
||||
int i, align = 1, a, sz = 0;
|
||||
|
||||
elements = malloc((argc + 1) * sizeof(ffi_type*));
|
||||
|
||||
/* find max required alignment and size: */
|
||||
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);
|
||||
}
|
||||
a = CTYPE_PRIMTYPE(base)->alignment;
|
||||
if (a > align) align = a;
|
||||
a = CTYPE_PRIMTYPE(base)->size;
|
||||
if (sz < a) sz = a;
|
||||
elements[i] = CTYPE_PRIMTYPE(base);
|
||||
}
|
||||
|
||||
elements[argc] = NULL;
|
||||
|
||||
/* round size up to alignment: */
|
||||
if ((sz % align) != 0) {
|
||||
sz += (align - (sz % align));
|
||||
}
|
||||
|
||||
/* libffi doesn't seem to support union types, but we try to make
|
||||
libffi work anyway by making a structure type. We put all the
|
||||
element types in the `elements' array, because their shapes may
|
||||
affect argument passing. */
|
||||
|
||||
/* Allocate the new libffi type object. */
|
||||
libffi_type = malloc(sizeof(ffi_type));
|
||||
libffi_type->size = sz;
|
||||
libffi_type->alignment = align;
|
||||
libffi_type->type = FFI_TYPE_STRUCT;
|
||||
libffi_type->elements = elements;
|
||||
|
||||
basetype = scheme_box(scheme_build_list(argc, argv));
|
||||
|
||||
@cmake["type" ctype "basetype"
|
||||
"(Scheme_Object*)libffi_type"
|
||||
"(Scheme_Object*)FOREIGN_union"]
|
||||
|
||||
scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
|
||||
|
||||
return (Scheme_Object*)type;
|
||||
}
|
||||
|
||||
/*****************************************************************************/
|
||||
/* Callback type */
|
||||
|
||||
|
|
@ -1084,6 +1210,8 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
|
|||
(if (procedure? c->s) (c->s x) (list c->s"("x")")))
|
||||
"scheme_void")})
|
||||
case FOREIGN_struct:
|
||||
case FOREIGN_array:
|
||||
case FOREIGN_union:
|
||||
if (gcsrc)
|
||||
return scheme_make_foreign_offset_cpointer(src, delta);
|
||||
else
|
||||
|
|
@ -1102,9 +1230,9 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
|
|||
* ptr */
|
||||
|
||||
/* Usually writes the C object to dst and returns NULL. When basetype_p is not
|
||||
* NULL, then any pointer value (any pointer or a struct) is returned, and the
|
||||
* 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 value will be *copied* into dst. */
|
||||
* then a struct or array value will be *copied* into dst. */
|
||||
static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
|
||||
Scheme_Object *val, intptr_t *basetype_p, intptr_t *_offset,
|
||||
int ret_loc)
|
||||
|
|
@ -1187,6 +1315,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
|
|||
@hush
|
||||
}}]))})
|
||||
case FOREIGN_struct:
|
||||
case FOREIGN_array:
|
||||
case FOREIGN_union:
|
||||
if (!SCHEME_FFIANYPTRP(val))
|
||||
scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);
|
||||
{
|
||||
|
|
@ -1199,7 +1329,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
|
|||
CTYPE_PRIMTYPE(type)->size);
|
||||
return NULL;
|
||||
} else {
|
||||
*basetype_p = FOREIGN_struct;
|
||||
*basetype_p = CTYPE_PRIMLABEL(type);
|
||||
if (_offset && is_gcable_pointer(val)) {
|
||||
*_offset = poff;
|
||||
return p;
|
||||
|
|
@ -1924,7 +2054,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
* be ignored by the GC is avalues.)
|
||||
*/
|
||||
GC_CAN_IGNORE ForeignAny *ivals, oval;
|
||||
void **avalues, *p, *newp, *tmp;
|
||||
void **avalues, *p, *newp;
|
||||
GC_CAN_IGNORE ForeignAny stack_ivals[MAX_QUICK_ARGS];
|
||||
void *stack_avalues[MAX_QUICK_ARGS];
|
||||
intptr_t stack_offsets[MAX_QUICK_ARGS];
|
||||
|
|
@ -1957,7 +2087,8 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
/* If this is a struct return value, then need to malloc in any case, even if
|
||||
* the size is smaller than ForeignAny, because this value will be
|
||||
* returned. */
|
||||
if (CTYPE_PRIMLABEL(base) == FOREIGN_struct) {
|
||||
if ((CTYPE_PRIMLABEL(base) == FOREIGN_struct)
|
||||
|| (CTYPE_PRIMLABEL(base) == FOREIGN_union)) {
|
||||
/* need to have p be a pointer that is invisible to the GC */
|
||||
p = malloc(CTYPE_PRIMTYPE(base)->size);
|
||||
newp = scheme_malloc_atomic(CTYPE_PRIMTYPE(base)->size);
|
||||
|
|
@ -1970,7 +2101,8 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
for (i=0; i<nargs; i++) {
|
||||
if ((avalues[i] == NULL) && !offsets[i]) /* if this was a non-pointer... */
|
||||
avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
|
||||
else if (ivals[i].x_fixnum != FOREIGN_struct) { /* if *not* a struct... */
|
||||
else if ((ivals[i].x_fixnum != FOREIGN_struct)
|
||||
&& (ivals[i].x_fixnum != FOREIGN_union)) { /* if *not* a struct... */
|
||||
/* ... set the ivals pointer (pointer type doesn't matter) and avalues */
|
||||
ivals[i].x_pointer = avalues[i];
|
||||
avalues[i] = &(ivals[i]);
|
||||
|
|
@ -1998,16 +2130,15 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
avalues = NULL;
|
||||
switch (CTYPE_PRIMLABEL(base)) {
|
||||
case FOREIGN_struct:
|
||||
case FOREIGN_union:
|
||||
memcpy(newp, p, CTYPE_PRIMTYPE(base)->size);
|
||||
free(p);
|
||||
p = newp;
|
||||
break;
|
||||
default:
|
||||
/* not sure why this code is here, looks fine to remove this case */
|
||||
if (CTYPE_PRIMTYPE(base) == &ffi_type_pointer) {
|
||||
tmp = ((void**)p)[0];
|
||||
p = &tmp;
|
||||
}
|
||||
case FOREIGN_array:
|
||||
/* array as result is treated as a pointer, so
|
||||
adjust `p' to make C2SCHEME work right */
|
||||
p = *(void **)p;
|
||||
break;
|
||||
}
|
||||
return C2SCHEME(otype, p, 0, 1, 1);
|
||||
|
|
@ -2052,7 +2183,7 @@ void free_fficall_data(void *ignored, void *p)
|
|||
scheme_wrong_type(MYNAME, "proper list", 1, argc, argv);
|
||||
if (NULL == (base = get_ctype_base(otype)))
|
||||
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
|
||||
rtype = CTYPE_PRIMTYPE(base);
|
||||
rtype = CTYPE_ARG_PRIMTYPE(base);
|
||||
abi = GET_ABI(MYNAME,3);
|
||||
if (argc > 4) {
|
||||
save_errno = -1;
|
||||
|
|
@ -2082,7 +2213,7 @@ void free_fficall_data(void *ignored, void *p)
|
|||
scheme_wrong_type(MYNAME, "list-of-C-types", 1, argc, argv);
|
||||
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
|
||||
scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv);
|
||||
atypes[i] = CTYPE_PRIMTYPE(base);
|
||||
atypes[i] = CTYPE_ARG_PRIMTYPE(base);
|
||||
}
|
||||
cif = malloc(sizeof(ffi_cif));
|
||||
if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
|
||||
|
|
@ -2138,7 +2269,7 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
|
|||
ffi_callback_struct *data;
|
||||
Scheme_Object *argv_stack[MAX_QUICK_ARGS];
|
||||
int argc = cif->nargs, i;
|
||||
Scheme_Object **argv, *p, *v;
|
||||
Scheme_Object **argv, *p, *v, *t;
|
||||
|
||||
data = extract_ffi_callback(userdata);
|
||||
|
||||
|
|
@ -2149,7 +2280,12 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
|
|||
if (data->sync && !SCHEME_PROCP(data->sync))
|
||||
scheme_start_in_scheduler();
|
||||
for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
|
||||
v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0, 0);
|
||||
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);
|
||||
} else
|
||||
v = C2SCHEME(t, args[i], 0, 0, 0);
|
||||
argv[i] = v;
|
||||
}
|
||||
p = _scheme_apply(data->proc, argc, argv);
|
||||
|
|
@ -2395,7 +2531,7 @@ void free_cl_cif_queue_args(void *ignored, void *p)
|
|||
scheme_wrong_type(MYNAME, "proper list", 1, argc, argv);
|
||||
if (NULL == (base = get_ctype_base(otype)))
|
||||
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
|
||||
rtype = CTYPE_PRIMTYPE(base);
|
||||
rtype = CTYPE_ARG_PRIMTYPE(base);
|
||||
abi = GET_ABI(MYNAME,3);
|
||||
is_atomic = ((argc > 4) && SCHEME_TRUEP(argv[4]));
|
||||
sync = (is_atomic ? scheme_true : NULL);
|
||||
|
|
@ -2432,7 +2568,7 @@ void free_cl_cif_queue_args(void *ignored, void *p)
|
|||
scheme_wrong_type(MYNAME, "list-of-C-types", 1, argc, argv);
|
||||
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
|
||||
scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv);
|
||||
atypes[i] = CTYPE_PRIMTYPE(base);
|
||||
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");
|
||||
|
|
|
|||
|
|
@ -13,12 +13,12 @@
|
|||
consistently.)
|
||||
*/
|
||||
|
||||
#define MZSCHEME_VERSION "5.1.3.2"
|
||||
#define MZSCHEME_VERSION "5.1.3.3"
|
||||
|
||||
#define MZSCHEME_VERSION_X 5
|
||||
#define MZSCHEME_VERSION_Y 1
|
||||
#define MZSCHEME_VERSION_Z 3
|
||||
#define MZSCHEME_VERSION_W 2
|
||||
#define MZSCHEME_VERSION_W 3
|
||||
|
||||
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
|
||||
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user