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

@@ -40,6 +40,7 @@ SYMBOL: +orig-wrapped-objects+
 TUPLE: test-implementation x ;
 C: <test-implementation> test-implementation
 
+[
     [
         {
             { IInherited {
@@ -56,7 +57,8 @@ C: <test-implementation> test-implementation
         dup +test-wrapper+ set [
 
             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
                 E_FAIL long <ref> long deref 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
@@ -97,11 +99,10 @@ C: <test-implementation> test-implementation
                     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

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