diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index ee62c10e50..fdaa5add17 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -105,10 +105,7 @@ TUPLE: alien-callback-params < alien-node-params xt ; infer-return ; : callback-xt ( word -- alien ) - callbacks get [ - dup "stack-cleanup" word-prop - [ callback-destructor new-disposable callback<< ] keep - ] cache ; + callbacks get [ dup "stack-cleanup" word-prop ] cache ; : callback-bottom ( params -- ) "( callback )" >>xt diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index b4c61e6ce3..29a3d0e35f 100644 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -65,7 +65,11 @@ HELP: free-callback { $description "Releases the callback heap memory allocated for an alien callback. " } { $warning "If the callback is invoked (either from C or Factor) after it has been freed, then Factor may crash." } ; -{ free-callback } related-words +HELP: with-callback +{ $values { "alien" alien } { "quot" quotation } } +{ $description "Calls the quotation with an alien value on the stack which is supposed to be a callback. Resources for the callback is guaranteed to be released afterwards." } ; + +{ free-callback unregister-and-free-callback with-callback } related-words HELP: alien-address { $values { "c-ptr" c-ptr } { "addr" "a non-negative integer" } } diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 12466ef5c1..20fb758efd 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs byte-arrays byte-vectors continuations.private -destructors init kernel kernel.private math namespaces sequences ; +USING: accessors assocs byte-arrays byte-vectors continuations +continuations.private destructors init kernel kernel.private math namespaces +sequences ; IN: alien BUILTIN: alien { underlying c-ptr read-only initial: f } expired ; @@ -111,15 +112,6 @@ SYMBOL: callbacks current-callback [ 2drop call ] [ swap call( callback -- ) drop ] 3bi ; inline -! Used by stack-checker.alien to register destructors for callbacks. -TUPLE: callback-destructor callback ; - -: delete-values ( value assoc -- ) - [ rot drop = not ] with assoc-filter! drop ; - -M: callback-destructor dispose ( disposable -- ) - callback>> [ callbacks get delete-values ] [ free-callback ] bi ; - ! A utility for defining global variables that are recompiled in ! every session TUPLE: expiry-check object alien ; @@ -127,8 +119,17 @@ TUPLE: expiry-check object alien ; : recompute-value? ( check -- ? ) dup [ alien>> expired? ] [ drop t ] if ; +: delete-values ( value assoc -- ) + [ rot drop = not ] with assoc-filter! drop ; + PRIVATE> +: unregister-and-free-callback ( alien -- ) + [ callbacks get delete-values ] [ free-callback ] bi ; + +: with-callback ( alien quot -- ) + over [ unregister-and-free-callback ] curry [ ] cleanup ; inline + : initialize-alien ( symbol quot -- ) swap dup get-global dup recompute-value? [ drop [ call dup 31337 expiry-check boa ] dip set-global ]