File: cx-gc.lisp

package info (click to toggle)
cl-contextl 0.40-2
  • links: PTS
  • area: main
  • in suites: lenny
  • size: 248 kB
  • ctags: 298
  • sloc: lisp: 2,271; makefile: 29
file content (79 lines) | stat: -rw-r--r-- 4,199 bytes parent folder | download
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
(in-package :contextl)

(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-held ((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-held ((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-held ((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))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (pushnew :contextl-layer-gc *features*))