blob: 963771913d557dd8d6687c2d60780235a3499b28 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
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))))
|
