! 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
! 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
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 [
-
- 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 [
+ [
+ {
+ { 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
+
+ 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
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
: 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