/usr/share/common-lisp/source/contextl/cx-gc.lisp is in cl-contextl 1:0.61-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 | (in-package :contextl)
#-cx-disable-layer-gc
(progn
(defun all-layer-contexts ()
(let ((result '()))
(labels ((collect (layer-context)
(declare (type layer-context layer-context))
(when (member layer-context result :test #'eq)
(return-from collect))
(push layer-context result)
(loop for (nil child) on (layer-context-children/ensure-active layer-context) by #'cddr do
(collect child))
(loop for (nil child) on (layer-context-children/ensure-inactive layer-context) by #'cddr do
(collect child))))
(when (boundp '*root-context*)
(collect (symbol-value '*root-context*))
result))))
(defun clear-layer-active-caches (test &optional (all-layer-contexts (all-layer-contexts)))
(loop for layer-context in all-layer-contexts do
(with-lock ((layer-context-lock layer-context))
(setf (layer-context-children/ensure-active layer-context)
(loop for (key child) on (layer-context-children/ensure-active layer-context) by #'cddr
unless (funcall test key)
nconc (list key child))))))
(defun clear-layer-inactive-caches (test &optional (all-layer-contexts (all-layer-contexts)))
(loop for layer-context in all-layer-contexts do
(with-lock ((layer-context-lock layer-context))
(setf (layer-context-children/ensure-inactive layer-context)
(loop for (key child) on (layer-context-children/ensure-inactive layer-context) by #'cddr
unless (funcall test key)
nconc (list key child))))))
(defgeneric clear-layer-context-caches (layer)
(:method ((layer symbol)) (clear-layer-context-caches (find-layer-class layer)))
(:method ((layer standard-layer-object)) (clear-layer-context-caches (find-layer-class layer)))
(:method ((layer-class cl:class))
(let ((all-layer-contexts (all-layer-contexts))
(test (lambda (key) (subtypep (find-layer-class key) layer-class))))
(clear-layer-active-caches test all-layer-contexts)
(clear-layer-inactive-caches test all-layer-contexts))))
(defun clear-layer-caches ()
(let ((all-layer-contexts (all-layer-contexts)))
(loop for layer-context in all-layer-contexts do
(with-lock ((layer-context-lock layer-context))
(setf (layer-context-children/ensure-active layer-context) '()
(layer-context-children/ensure-inactive layer-context) '())))))
(defmethod reinitialize-instance :after
((class standard-layer-class) &rest initargs)
(declare (ignore initargs))
(clear-layer-context-caches class))
(defgeneric clear-activation-method-caches (gf method)
(:method (gf method) (declare (ignore gf method)) nil)
(:method ((gf (eql (lf-definer-name 'adjoin-layer-using-class))) method)
(let ((layer-specializer (first (layered-method-specializers method))))
(if (typep layer-specializer 'eql-specializer)
(let ((eql-specializer-object (eql-specializer-object layer-specializer)))
(clear-layer-active-caches (lambda (key) (eql (find-layer-class key) eql-specializer-object))))
(clear-layer-active-caches (lambda (key) (typep (find-layer-class key) layer-specializer))))))
(:method ((gf (eql (lf-definer-name 'remove-layer-using-class))) method)
(let ((layer-specializer (first (layered-method-specializers method))))
(if (typep layer-specializer 'eql-specializer)
(let ((eql-specializer-object (eql-specializer-object layer-specializer)))
(clear-layer-inactive-caches (lambda (key) (eql (find-layer-class key) eql-specializer-object))))
(clear-layer-inactive-caches (lambda (key) (typep (find-layer-class key) layer-specializer)))))))
(defmethod add-method :after
((gf layered-function) (method layered-method))
(clear-activation-method-caches (generic-function-name gf) method))
(defmethod remove-method :after
((gf layered-function) (method layered-method))
(clear-activation-method-caches (generic-function-name gf) method)))
|