pools docs, better implementation

extra/pools/pools-docs.factor

@@ -0,0 +1,76 @@
+! (c)2009 Joe Groff bsd license
+USING: classes help.markup help.syntax kernel math ;
+IN: pools
+
+HELP: <pool>
+{ $values
+    { "size" integer } { "class" class }
+    { "pool" pool }
+}
+{ $description "Creates a " { $link pool } " of " { $snippet "size" } " objects of " { $snippet "class" } "." } ;
+
+HELP: POOL:
+{ $syntax "POOL: class size" }
+{ $description "Creates a " { $link pool } " of " { $snippet "size" } " objects of " { $snippet "class" } ", and associates it with the class using " { $link set-class-pool } "." } ;
+
+HELP: class-pool
+{ $values
+    { "class" class }
+    { "pool" pool }
+}
+{ $description "Returns the " { $link pool } " associated with " { $snippet "class" } ", or " { $link f } " if no pool is associated." } ;
+
+HELP: free-to-pool
+{ $values
+    { "object" object }
+}
+{ $description "Frees an object from the " { $link pool } " it was allocated from. The object must have been allocated by " { $link new-from-pool } "." } ;
+
+HELP: new-from-pool
+{ $values
+    { "class" class }
+    { "object" object }
+}
+{ $description "Allocates an object from the " { $link pool } " associated with " { $snippet "class" } ". If the pool is exhausted, " { $link f } " is returned." } ;
+
+{ POSTPONE: POOL: class-pool set-class-pool new-from-pool free-to-pool } related-words
+
+HELP: pool
+{ $class-description "A " { $snippet "pool" } " contains a fixed-size set of preallocated tuple objects. Once the pool has been allocated, its objects can be allocated with " { $link pool-new } " and freed with " { $link pool-free } " in constant time. A pool can also be associated with its class with the " { $link POSTPONE: POOL: } " syntax or the " { $link set-class-pool } " word, after which the words " { $link new-from-pool } " and " { $link free-to-pool } " can be used with the class name to allocate and free objects." } ;
+
+HELP: pool-free
+{ $values
+    { "object" object } { "pool" pool }
+}
+{ $description "Frees an object back into " { $link pool } "." } ;
+
+HELP: pool-size
+{ $values
+    { "pool" pool }
+    { "size" integer }
+}
+{ $description "Returns the number of unallocated objects inside a " { $link pool } "." } ;
+
+HELP: pool-new
+{ $values
+    { "pool" pool }
+    { "object" object }
+}
+{ $description "Returns an unallocated object out of a " { $link pool } ". If the pool is exhausted, " { $link f } " is returned." } ;
+
+{ pool <pool> pool-new pool-free pool-size } related-words
+
+HELP: set-class-pool
+{ $values
+    { "class" class } { "pool" pool }
+}
+{ $description "Associates a " { $link pool } " with " { $snippet "class" } "." } ;
+
+ARTICLE: "pools" "Pools"
+"The " { $vocab-link "pools" } " vocabulary provides " { $link pool } " objects which manage preallocated collections of objects."
+{ $subsection pool }
+{ $subsection POSTPONE: POOL: }
+{ $subsection new-from-pool }
+{ $subsection free-to-pool } ;
+
+ABOUT: "pools"

extra/pools/pools-tests.factor

@@ -3,23 +3,25 @@ USING: kernel pools tools.test ;
 IN: pools.tests
 
 TUPLE: foo x ;
-POOL: foo 2
 
 [ 1 ] [
-    foo class-pool pool-empty 
+    foo 2 foo <pool> set-class-pool
+
     foo new-from-pool drop
-    foo class-pool pool-free-size
+    foo class-pool pool-size
 ] unit-test
 
 [ T{ foo } T{ foo } f ] [
-    foo class-pool pool-empty 
+    foo 2 foo <pool> set-class-pool
+
     foo new-from-pool
     foo new-from-pool
     foo new-from-pool
 ] unit-test
 
 [ f ] [
-    foo class-pool pool-empty 
+    foo 2 foo <pool> set-class-pool
+
     foo new-from-pool
     foo new-from-pool
     eq?

extra/pools/pools.factor

@@ -1,26 +1,21 @@
 ! (c)2009 Joe Groff bsd license
 USING: accessors arrays bit-arrays classes
 classes.tuple.private fry kernel locals parser
-sequences sequences.private words ;
+sequences sequences.private vectors words ;
 IN: pools
 
 TUPLE: pool
     prototype
-    { objects array }
-    { free bit-array } ;
+    { objects vector } ;
 
 : <pool> ( size class -- pool )
     [ nip new ]
-    [ [ iota ] dip '[ _ new ] replicate ]
-    [ drop <bit-array> ] 2tri
+    [ [ iota ] dip '[ _ new ] V{ } replicate-as ] 2bi
     pool boa ;
 
 : pool-size ( pool -- size )
     objects>> length ;
 
-: pool-free-size ( pool -- free-size )
-    free>> [ f = ] filter length ;
-
 <PRIVATE
 
 :: copy-tuple ( from to -- to )
@@ -29,11 +24,7 @@ TUPLE: pool
     to ; inline
 
 : (pool-new) ( pool -- object )
-    [ free>> [ f = ] find drop ] [
-        over [
-            [ objects>> nth ] [ [ t ] 2dip free>> set-nth ] 2bi
-        ] [ drop ] if
-    ] bi ;
+    objects>> [ f ] [ pop ] if-empty ;
 
 : (pool-init) ( pool object -- object )
     [ prototype>> ] dip copy-tuple ; inline
@@ -44,11 +35,7 @@ PRIVATE>
     dup (pool-new) [ (pool-init) ] [ drop f ] if* ; inline
 
 : pool-free ( object pool -- )
-    [ objects>> [ eq? ] with find drop ]
-    [ [ f ] 2dip free>> set-nth ] bi ;
-
-: pool-empty ( pool -- )
-    free>> [ length iota ] keep [ [ f ] 2dip set-nth ] curry each ;
+    objects>> push ;
 
 : class-pool ( class -- pool )
     "pool" word-prop ;
@@ -64,3 +51,4 @@ PRIVATE>
 
 SYNTAX: POOL:
     scan-word scan-word '[ _ swap <pool> ] [ swap set-class-pool ] bi ;
+