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).

basis/stack-checker/alien/alien.factor

@@ -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

basis/windows/com/com-tests.factor

@@ -41,67 +41,68 @@ TUPLE: test-implementation x ;
 C: <test-implementation> test-implementation
 
 [
-    {
+    [
-        { IInherited {
+        {
-            [ drop S_OK ] ! ISimple::returnOK
+            { IInherited {
-            [ drop E_FAIL ] ! ISimple::returnError
+                [ drop S_OK ] ! ISimple::returnOK
-            [ x>> ] ! IInherited::getX
+                [ drop E_FAIL ] ! ISimple::returnError
-            [ >>x drop ] ! IInherited::setX
+                [ x>> ] ! IInherited::getX
-        } }
+                [ >>x drop ] ! IInherited::setX
-        { IUnrelated {
+            } }
-            [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus
+            { IUnrelated {
-            [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrelated::xMulAdd
+                [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus
-        } }
+                [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrelated::xMulAdd
-    } <com-wrapper>
+            } }
-    dup +test-wrapper+ set [
+        } <com-wrapper>
+        dup +test-wrapper+ set [
 
-        0 <test-implementation> swap com-wrap
+            0 <test-implementation> swap com-wrap
-        dup +guinea-pig-implementation+ set [ drop
+            dup +guinea-pig-implementation+ set [
+                drop
 
-            S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test
+                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
+                E_FAIL long <ref> long deref 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
-            20 1array [
+                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 ]
+                2array [
-                [ IInherited::getX ] bi
+                    +guinea-pig-implementation+ get IUnrelated-iid com-query-interface
-            ] unit-test
+                    dup ISimple-iid com-query-interface
-            420 1array [
+                    over com-release dup com-release
-                +guinea-pig-implementation+ get
+                ] unit-test
-                IUnrelated-iid com-query-interface
+            ] with-com-interface
-                [ 20 20 IUnrelated::xMulAdd ] with-com-interface
+        ] with-disposal
-            ] unit-test
+    ] with-compilation-unit
-            40 1array [
+] with-destructors
-                +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
 
 ! Ensure that we freed +guinea-pig-implementation
 +orig-wrapped-objects+ get-global 1array [ +wrapped-objects+ get-global ] unit-test

core/alien/alien-tests.factor

@@ -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
+alien.syntax arrays byte-arrays continuations destructors fry kernel
-libc math namespaces prettyprint sequences sets system tools.test ;
+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