This file is indexed.

/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)