From 3f659840555358d31a634cee2d71c92ee5edf948 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Lindqvist?= Date: Wed, 17 Sep 2014 12:26:00 +0200 Subject: [PATCH] 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 | 15 +++- basis/windows/com/com-tests.factor | 117 +++++++++++++------------ core/alien/alien-tests.factor | 22 ++++- 3 files changed, 91 insertions(+), 63 deletions(-) diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index 7a712e1b9c..fab94157d1 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/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 ] cache ; + callbacks get [ + dup "stack-cleanup" word-prop + callback-destructor boa &dispose callback>> + ] cache ; : callback-bottom ( params -- ) "( callback )" >>xt diff --git a/basis/windows/com/com-tests.factor b/basis/windows/com/com-tests.factor index 43e99d739a..adfbb832b2 100644 --- a/basis/windows/com/com-tests.factor +++ b/basis/windows/com/com-tests.factor @@ -41,67 +41,68 @@ TUPLE: test-implementation x ; C: 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 - } } - } - 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 + } } + } + dup +test-wrapper+ set [ - 0 swap com-wrap - dup +guinea-pig-implementation+ set [ drop + 0 swap com-wrap + dup +guinea-pig-implementation+ set [ + drop - S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test - E_FAIL long 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 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 +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 - +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 diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index f6de02b621..038d866786 100644 --- a/core/alien/alien-tests.factor +++ b/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 -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 ] produce-until-error nip [ free-callback ] each ; -[ ] [ +{ } [ 10 [ fill-and-free-callback-heap ] times ] unit-test + +: ( -- alien ) + \ int { pointer: void pointer: void } \ cdecl + [ 2drop 37 ] alien-callback ; + +: call-cb ( -- ret ) + f f \ 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