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

fix ffi handling of non-GCable pointers with offsets

Browse Source 
Closes PR 11567
This commit is contained in:
Matthew Flatt 2010-12-25 09:31:38 -06:00
parent 8bb2543b34
commit e7b52bf10f
3 changed files with 37 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -256,6 +256,25 @@
(test 'hello hash-ref ht seventeen2 #f)
(test 'hello hash-ref ht seventeen3 #f)))
;; Check proper handling of offsets:
(let ()
(define scheme_make_sized_byte_string
(get-ffi-obj 'scheme_make_sized_byte_string #f (_fun _pointer _long _int -> _scheme)))
;; Non-gcable:
(let ()
(define p (cast (ptr-add #f 20) _pointer _pointer))
(define d (scheme_make_sized_byte_string (ptr-add p 24)
4
0))
(test 44 values (cast d _pointer _long)))
;; GCable:
(let ()
(define p (cast (ptr-add #f 20) _pointer _gcpointer))
(define d (scheme_make_sized_byte_string (ptr-add p 24)
4
0))
(test 44 values (cast d _gcpointer _long))))
(delete-test-files)
(report-errs)

14
src/foreign/foreign.c
View File

@ -1676,12 +1676,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
void* tmp; intptr_t toff;
tmp = (void*)(SCHEME_FFIANYPTR_VAL(val));
toff = SCHEME_FFIANYPTR_OFFSET(val);
if (_offset) *_offset = toff;
if (basetype_p == NULL || (tmp == NULL && toff == 0) || !is_gcable_pointer(val)) {
(((void**)W_OFFSET(dst,delta))[0]) = (_offset ? tmp : (void*)W_OFFSET(tmp, toff));
if (_offset) *_offset = 0;
(((void**)W_OFFSET(dst,delta))[0]) = (void*)W_OFFSET(tmp, toff);;
return NULL;
} else {
*basetype_p = FOREIGN_pointer;
toff = SCHEME_FFIANYPTR_OFFSET(val);
if (_offset) *_offset = toff;
return _offset ? tmp : (void*)W_OFFSET(tmp, toff);
}
} else {
@ -1699,12 +1701,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
void* tmp; intptr_t toff;
tmp = (void*)(SCHEME_FFIANYPTR_VAL(val));
toff = SCHEME_FFIANYPTR_OFFSET(val);
if (_offset) *_offset = toff;
if (basetype_p == NULL || (tmp == NULL && toff == 0) || 0) {
(((void**)W_OFFSET(dst,delta))[0]) = (_offset ? tmp : (void*)W_OFFSET(tmp, toff));
if (_offset) *_offset = 0;
(((void**)W_OFFSET(dst,delta))[0]) = (void*)W_OFFSET(tmp, toff);;
return NULL;
} else {
*basetype_p = FOREIGN_gcpointer;
toff = SCHEME_FFIANYPTR_OFFSET(val);
if (_offset) *_offset = toff;
return _offset ? tmp : (void*)W_OFFSET(tmp, toff);
}
} else {
@ -1749,7 +1753,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
return NULL;
} else {
*basetype_p = FOREIGN_struct;
if (_offset) {
if (_offset && is_gcable_pointer(val)) {
*_offset = poff;
return p;
} else {

17
src/foreign/foreign.rktc
View File

@ -1156,10 +1156,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
if (@f[pred]) {
@ctype tmp@";"@and[offset]{ intptr_t toff@";"}
tmp = (@ctype)(@f[s->c]);
@and[offset @list{
toff = SCHEME_@|offset|_OFFSET(val);
if (_offset) *_offset = toff;@;
@"\n" }]@;
@and[offset @list{toff = SCHEME_@|offset|_OFFSET(val);@"\n"}]@;
@(if ptr?
@list{if (basetype_p == NULL || @;
@(if offset
@ -1168,13 +1165,17 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
@(if (equal? ftype "pointer")
@list{!is_gcable_pointer(val)}
@list{0})) {
@and[offset @list{if (_offset) *_offset = 0;@"\n"}]@;
@x = @(if offset
@list{(_offset ? tmp : @;
(@ctype)W_OFFSET(tmp, toff))}
"tmp");
@list{(@ctype)W_OFFSET(tmp, toff);}
"tmp");
return NULL;
} else {
*basetype_p = FOREIGN_@cname;
@and[offset @list{
toff = SCHEME_@|offset|_OFFSET(val);
if (_offset) *_offset = toff;@;
@"\n" }]@;
return @(if offset
@list{_offset ? tmp : @;
(@ctype)W_OFFSET(tmp, toff)}
@ -1199,7 +1200,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
return NULL;
} else {
*basetype_p = FOREIGN_struct;
if (_offset) {
if (_offset && is_gcable_pointer(val)) {
*_offset = poff;
return p;
} else {