stack-checker.alien: use free-callback as a destructor when creating
callbacks + tests proving it works. now in case you create temporary callbacks you can enclose them in with-destructors and it will just work(tm).db4
Björn Lindqvist
John Benediktsson
parent
8fb317b721
commit
3f65984055
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays sequences accessors combinators math
|
||||
USING: kernel destructors arrays sequences accessors combinators math
|
||||
namespaces init sets words assocs alien.libraries alien
|
||||
alien.private alien.c-types fry quotations strings
|
||||
stack-checker.backend stack-checker.errors stack-checker.visitor
|
||||
|
|
@ -104,8 +104,19 @@ TUPLE: alien-callback-params < alien-node-params xt ;
|
|||
! Quotation which coerces return value to required type
|
||||
infer-return ;
|
||||
|
||||
: delete-values ( value assoc -- )
|
||||
[ rot drop = not ] with assoc-filter! drop ;
|
||||
|
||||
TUPLE: callback-destructor callback ;
|
||||
|
||||
M: callback-destructor dispose ( disposable -- )
|
||||
callback>> [ callbacks get delete-values ] [ free-callback ] bi ;
|
||||
|
||||
: callback-xt ( word -- alien )
|
||||
callbacks get [ dup "stack-cleanup" word-prop <callback> ] cache ;
|
||||
callbacks get [
|
||||
dup "stack-cleanup" word-prop <callback>
|
||||
callback-destructor boa &dispose callback>>
|
||||
] cache ;
|
||||
|
||||
: callback-bottom ( params -- )
|
||||
"( callback )" <uninterned-word> >>xt
|
||||
|
|
|
|||
|
|
@ -41,67 +41,68 @@ TUPLE: test-implementation x ;
|
|||
C: <test-implementation> test-implementation
|
||||
|
||||
[
|
||||
{
|
||||
{ IInherited {
|
||||
[ drop S_OK ] ! ISimple::returnOK
|
||||
[ drop E_FAIL ] ! ISimple::returnError
|
||||
[ x>> ] ! IInherited::getX
|
||||
[ >>x drop ] ! IInherited::setX
|
||||
} }
|
||||
{ IUnrelated {
|
||||
[ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus
|
||||
[ [ x>> ] [ * ] [ + ] tri* ] ! IUnrelated::xMulAdd
|
||||
} }
|
||||
} <com-wrapper>
|
||||
dup +test-wrapper+ set [
|
||||
[
|
||||
{
|
||||
{ IInherited {
|
||||
[ drop S_OK ] ! ISimple::returnOK
|
||||
[ drop E_FAIL ] ! ISimple::returnError
|
||||
[ x>> ] ! IInherited::getX
|
||||
[ >>x drop ] ! IInherited::setX
|
||||
} }
|
||||
{ IUnrelated {
|
||||
[ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus
|
||||
[ [ x>> ] [ * ] [ + ] tri* ] ! IUnrelated::xMulAdd
|
||||
} }
|
||||
} <com-wrapper>
|
||||
dup +test-wrapper+ set [
|
||||
|
||||
0 <test-implementation> swap com-wrap
|
||||
dup +guinea-pig-implementation+ set [ drop
|
||||
0 <test-implementation> swap com-wrap
|
||||
dup +guinea-pig-implementation+ set [
|
||||
drop
|
||||
|
||||
S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test
|
||||
E_FAIL long <ref> long deref 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
|
||||
20 1array [
|
||||
S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test
|
||||
E_FAIL long <ref> long deref 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
|
||||
20 1array [
|
||||
+guinea-pig-implementation+ get
|
||||
[ 20 IInherited::setX ]
|
||||
[ IInherited::getX ] bi
|
||||
] unit-test
|
||||
420 1array [
|
||||
+guinea-pig-implementation+ get
|
||||
IUnrelated-iid com-query-interface
|
||||
[ 20 20 IUnrelated::xMulAdd ] with-com-interface
|
||||
] unit-test
|
||||
40 1array [
|
||||
+guinea-pig-implementation+ get
|
||||
IUnrelated-iid com-query-interface
|
||||
[ 20 IUnrelated::xPlus ] with-com-interface
|
||||
] unit-test
|
||||
|
||||
+guinea-pig-implementation+ get 1array [
|
||||
+guinea-pig-implementation+ get com-add-ref
|
||||
] unit-test
|
||||
|
||||
{ } [ +guinea-pig-implementation+ get com-release ] unit-test
|
||||
|
||||
+guinea-pig-implementation+ get 1array [
|
||||
+guinea-pig-implementation+ get IUnknown-iid com-query-interface
|
||||
dup com-release
|
||||
] unit-test
|
||||
+guinea-pig-implementation+ get 1array [
|
||||
+guinea-pig-implementation+ get ISimple-iid com-query-interface
|
||||
dup com-release
|
||||
] unit-test
|
||||
void* heap-size +guinea-pig-implementation+ get <displaced-alien>
|
||||
+guinea-pig-implementation+ get
|
||||
[ 20 IInherited::setX ]
|
||||
[ IInherited::getX ] bi
|
||||
] unit-test
|
||||
420 1array [
|
||||
+guinea-pig-implementation+ get
|
||||
IUnrelated-iid com-query-interface
|
||||
[ 20 20 IUnrelated::xMulAdd ] with-com-interface
|
||||
] unit-test
|
||||
40 1array [
|
||||
+guinea-pig-implementation+ get
|
||||
IUnrelated-iid com-query-interface
|
||||
[ 20 IUnrelated::xPlus ] with-com-interface
|
||||
] unit-test
|
||||
|
||||
+guinea-pig-implementation+ get 1array [
|
||||
+guinea-pig-implementation+ get com-add-ref
|
||||
] unit-test
|
||||
|
||||
{ } [ +guinea-pig-implementation+ get com-release ] unit-test
|
||||
|
||||
+guinea-pig-implementation+ get 1array [
|
||||
+guinea-pig-implementation+ get IUnknown-iid com-query-interface
|
||||
dup com-release
|
||||
] unit-test
|
||||
+guinea-pig-implementation+ get 1array [
|
||||
+guinea-pig-implementation+ get ISimple-iid com-query-interface
|
||||
dup com-release
|
||||
] unit-test
|
||||
void* heap-size +guinea-pig-implementation+ get <displaced-alien>
|
||||
+guinea-pig-implementation+ get
|
||||
2array [
|
||||
+guinea-pig-implementation+ get IUnrelated-iid com-query-interface
|
||||
dup ISimple-iid com-query-interface
|
||||
over com-release dup com-release
|
||||
] unit-test
|
||||
|
||||
] with-com-interface
|
||||
|
||||
] with-disposal
|
||||
] with-compilation-unit
|
||||
2array [
|
||||
+guinea-pig-implementation+ get IUnrelated-iid com-query-interface
|
||||
dup ISimple-iid com-query-interface
|
||||
over com-release dup com-release
|
||||
] unit-test
|
||||
] with-com-interface
|
||||
] with-disposal
|
||||
] with-compilation-unit
|
||||
] with-destructors
|
||||
|
||||
! Ensure that we freed +guinea-pig-implementation
|
||||
+orig-wrapped-objects+ get-global 1array [ +wrapped-objects+ get-global ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
USING: accessors alien alien.accessors alien.c-types alien.libraries
|
||||
alien.syntax arrays byte-arrays continuations fry kernel kernel.private layouts
|
||||
libc math namespaces prettyprint sequences sets system tools.test ;
|
||||
alien.syntax arrays byte-arrays continuations destructors fry kernel
|
||||
kernel.private layouts libc math namespaces prettyprint sequences sets system
|
||||
tools.test ;
|
||||
FROM: namespaces => set ;
|
||||
IN: alien.tests
|
||||
|
||||
|
|
@ -96,6 +97,21 @@ SYMBOL: foo
|
|||
: fill-and-free-callback-heap ( -- )
|
||||
[ \ foo 33 <callback> ] produce-until-error nip [ free-callback ] each ;
|
||||
|
||||
[ ] [
|
||||
{ } [
|
||||
10 [ fill-and-free-callback-heap ] times
|
||||
] unit-test
|
||||
|
||||
: <cb-creator> ( -- alien )
|
||||
\ int { pointer: void pointer: void } \ cdecl
|
||||
[ 2drop 37 ] alien-callback ;
|
||||
|
||||
: call-cb ( -- ret )
|
||||
f f <cb-creator> \ int { pointer: void pointer: void } \ cdecl
|
||||
alien-indirect ;
|
||||
|
||||
! Will fail if the callbacks cache gets out of sync
|
||||
{ 37 37 } [
|
||||
[ call-cb ] with-destructors
|
||||
fill-and-free-callback-heap
|
||||
[ call-cb ] with-destructors
|
||||
] unit-test
|
||||
|
|
|
|||
Loading…
Reference in New Issue