From 8fb317b7210efaceb1cfa664abf004c1660d1fa4 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Bj=C3=B6rn=20Lindqvist?= <bjourne@gmail.com>
Date: Tue, 16 Sep 2014 17:14:39 +0200
Subject: [PATCH] alien: a test and docs for free-callback

---
 core/alien/alien-docs.factor  |  7 +++++++
 core/alien/alien-tests.factor | 22 ++++++++++++++++++----
 2 files changed, 25 insertions(+), 4 deletions(-)

diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
index 4230d14631..b4c61e6ce3 100644
--- a/core/alien/alien-docs.factor
+++ b/core/alien/alien-docs.factor
@@ -60,6 +60,13 @@ $nl
 
 { <alien> <displaced-alien> alien-address } related-words
 
+HELP: free-callback
+{ $values { "alien" alien } }
+{ $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." } ;
+
+{ <callback> free-callback } related-words
+
 HELP: alien-address
 { $values { "c-ptr" c-ptr } { "addr" "a non-negative integer" } }
 { $description "Outputs the address of an alien." }
diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor
index 075a672bbd..f6de02b621 100644
--- a/core/alien/alien-tests.factor
+++ b/core/alien/alien-tests.factor
@@ -1,6 +1,6 @@
-USING: accessors alien alien.accessors alien.syntax byte-arrays arrays
-kernel kernel.private namespaces tools.test sequences libc math
-system prettyprint layouts alien.libraries sets ;
+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 ;
 FROM: namespaces => set ;
 IN: alien.tests
 
@@ -48,7 +48,7 @@ cell 8 = [
       0x123412341234 over 0 set-alien-signed-8
       0 alien-signed-8
     ] unit-test
-    
+
     [ 0x123412341234 ] [
       8 <byte-array>
       0x123412341234 over 0 set-alien-signed-cell
@@ -85,3 +85,17 @@ f initialize-test set-global
 [ 7575 ] [ initialize-test [ 7575 ] initialize-alien ] unit-test
 
 [ { BAD-ALIEN } ] [ { BAD-ALIEN BAD-ALIEN BAD-ALIEN } members ] unit-test
+
+! Generate callbacks until the whole callback-heap is full, then free
+! them. Do it ten times in a row for good measure.
+: produce-until-error ( quot -- error seq )
+    '[ [ @ t ] [ f ] recover ] [ ] produce ; inline
+
+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