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
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
|
;; garbage-pools.lisp
(defpackage :garbage-pools
(:use #:cl)
(:export #:pool
#:with-garbage-pool
#:cleanup-register
#:cleanup-pool
#:cleanup-object
#:cancel-object-cleanup
#:object-register
#:defcleanup))
(in-package #:garbage-pools)
(defvar *pool*)
;;; pool
(defclass pool ()
((register-pairs :initform nil :accessor register-pairs)))
;;; cleanup-register
(defun cleanup-register (object cleanup-fun &optional (pool *pool*))
(push (cons object cleanup-fun)
(register-pairs pool))
object)
;;; cleanup-pool
(defun cleanup-pool (&optional (pool *pool*))
(dolist (pair (register-pairs pool))
(let ((obj (car pair))
(cleanup-fun (cdr pair)))
(if (and obj cleanup-fun)
(funcall cleanup-fun obj)))
(setf (register-pairs pool) nil)))
;;; cleanup-object
(defun cleanup-object (object &optional (pool *pool*))
(let ((pair (find object (register-pairs pool) :key #'car :test #'eq)))
(if (and pair (car pair) (cdr pair))
(funcall (cdr pair) (car pair)))
(delete pair (register-pairs pool))))
;;; cancel-cleanup
(defun cancel-object-cleanup (object &optional (pool *pool*))
(let ((pair (find object (register-pairs pool) :key #'car :test #'eq)))
(if pair
(delete pair (register-pairs pool)))))
;;; with-garbage-pool
(defmacro with-garbage-pool ((&optional (var '*pool*)) &body body)
`(let ((,var (make-instance 'pool)))
(unwind-protect
(progn ,@body)
(cleanup-pool ,var))))
;;; object-register
(defgeneric object-register (object &optional pool))
(defmethod object-register ((empty (eql nil)) &optional (pool garbage-pools::*pool*))
(declare (ignore pool)))
;;; defcleanup
(defmacro defcleanup (class cleanup-fun)
`(defmethod garbage-pools:object-register ((object ,class) &optional (pool garbage-pools::*pool*))
(garbage-pools:cleanup-register object ,cleanup-fun pool)))
(defcleanup pool #'cleanup-pool)
(defcleanup stream #'close)
|
