1 files changed, 59 insertions, 0 deletions
diff --git a/chickadee/data/pool.scm b/chickadee/data/pool.scm
new file mode 100644
index 0000000..9637719
--- /dev/null
+++ b/chickadee/data/pool.scm
@@ -0,0 +1,59 @@
+(define-module (chickadee data pool)
+  #:use-module (chickadee data array-list)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
+  #:export (make-pool
+            pool?
+            pool-borrow
+            pool-return))
+
+(define-record-type <pool>
+  (%make-pool pred fresh init free)
+  pool?
+  (pred pool-pred)
+  (fresh pool-fresh)
+  (init pool-init)
+  (free pool-free))
+
+(define (make-pool pred fresh init)
+  (%make-pool pred fresh init (make-array-list)))
+
+(define-syntax-rule (borrow+init pool args ...)
+  (match pool
+    (($ <pool> pred fresh init free)
+     (let ((obj (if (array-list-empty? free)
+                    (fresh)
+                    (array-list-pop! free))))
+       (init obj args ...)
+       obj))))
+
+(define pool-borrow
+  (case-lambda
+    ((pool)
+     (borrow+init pool))
+    ((pool a)
+     (borrow+init pool a))
+    ((pool a b)
+     (borrow+init pool a b))
+    ((pool a b c)
+     (borrow+init pool a b c))
+    ((pool a b c d)
+     (borrow+init pool a b c d))
+    ((pool a b c d e)
+     (borrow+init pool a b c d e))
+    ((pool . args)
+     (match pool
+       (($ <pool> pred fresh init free)
+        (let ((obj (if (array-list-empty? free)
+                       (fresh)
+                       (array-list-pop! free))))
+          (apply init obj args)
+          obj))))))
+(set-procedure-property! pool-borrow 'name 'pool-borrow)
+
+(define (pool-return pool obj)
+  (match pool
+    (($ <pool> pred fresh init free)
+     (unless (pred obj)
+       (error "invalid pool object" obj))
+     (array-list-push! free obj))))