/usr/share/common-lisp/source/garbage-pools/garbage-pools.lisp is in cl-garbage-pools 20130720-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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)
|