cl-contextl 1:0.61-1 / usr / share / common-lisp / source / contextl / cx-layered-access-class.lisp

This file is indexed.

/usr/share/common-lisp/source/contextl/cx-layered-access-class.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
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
(in-package :contextl)

(defclass layered-access-class (standard-class)
  ())

(defmethod validate-superclass
           ((class layered-access-class)
            (superclass standard-class))
  t)

(defgeneric slot-definition-layeredp (slot)
  (:method ((slot slot-definition)) nil))

(defclass layered-direct-slot-definition (standard-direct-slot-definition)
  ((layeredp :initarg :layered
             :initform nil
             :reader slot-definition-layeredp)
   (layered-readers :initarg :layered-readers
                    :initform ()
                    :reader slot-definition-layered-readers)
   (layered-writers :initarg :layered-writers
                    :initform ()
                    :reader slot-definition-layered-writers)
   (layered-accessor-methods :initform ()
                             :accessor layered-accessor-methods)))

(defclass layered-effective-slot-definition (standard-effective-slot-definition)
  ())

(defmethod slot-definition-layeredp ((slot layered-effective-slot-definition))
  t)

(defmethod direct-slot-definition-class
           ((class layered-access-class) &key &allow-other-keys)
  (find-class 'layered-direct-slot-definition))

(defvar *layered-effective-slot-definition-class*)

(defmethod effective-slot-definition-class
           ((class layered-access-class) &key &allow-other-keys)
  (if *layered-effective-slot-definition-class*
    *layered-effective-slot-definition-class*
    (call-next-method)))

(defmethod compute-effective-slot-definition
           ((class layered-access-class) name direct-slot-definitions)
  (declare (ignore name))
  (let ((*layered-effective-slot-definition-class*
         (when (some #'slot-definition-layeredp direct-slot-definitions)
           (find-class 'layered-effective-slot-definition))))
    (call-next-method)))

(define-layered-function slot-value-using-layer (class object slot reader)
  (:method (class object slot reader)
   (declare (ignore class object slot))
   (funcall reader)))

(defmethod slot-value-using-class :around
  ((class layered-access-class) object (slot layered-effective-slot-definition))
  (flet ((reader () (call-next-method)))
    (slot-value-using-layer class object slot #'reader)))

(define-layered-function (setf slot-value-using-layer) (new-value class object slot writer)
  (:method (new-value class object slot writer)
   (declare (ignore class object slot))
   (funcall writer new-value)))

(defmethod (setf slot-value-using-class) :around
  (new-value (class layered-access-class) object (slot layered-effective-slot-definition))
  (flet ((writer (new-value) (call-next-method new-value class object slot)))
    (setf (slot-value-using-layer class object slot #'writer)
          new-value)))

(define-layered-function slot-boundp-using-layer (class object slot reader)
  (:method (class object slot reader)
   (declare (ignore class object slot))
   (funcall reader)))

(defmethod slot-boundp-using-class :around
  ((class layered-access-class) object (slot layered-effective-slot-definition))
  (flet ((reader () (call-next-method)))
    (slot-boundp-using-layer class object slot #'reader)))

(define-layered-function slot-makunbound-using-layer (class object slot writer)
  (:method (class object slot writer)
   (declare (ignore class object slot))
   (funcall writer)))

(defmethod slot-makunbound-using-class :around
  ((class layered-access-class) object (slot layered-effective-slot-definition))
  (flet ((writer () (call-next-method)))
    (slot-makunbound-using-layer class object slot #'writer)))

(defgeneric process-layered-access-slot-specification (slot-spec)
  (:method ((slot-spec symbol)) slot-spec)
  (:method ((slot-spec cons))
   (let ((plist (cdr slot-spec)))
     (if (get-properties plist '(:layered-reader :layered-writer :layered-accessor))
       (loop for (key value) on plist by #'cddr
             if (eq key :layered-reader)
             collect value into layered-readers
             else if (eq key :layered-writer)
             collect value into layered-writers
             else if (eq key :layered-accessor)
             collect value into layered-readers
             and collect `(setf ,value) into layered-writers
             else nconc (list key value) into other-initargs
             finally (return (list* (car slot-spec)
                                    :layered-readers layered-readers
                                    :layered-writers layered-writers
                                    other-initargs)))
       slot-spec))))

(defgeneric add-layered-accessors (class)
  (:method ((class layered-access-class))
   (loop with reader-specializers = (list class)
         with writer-specializers = (list (find-class 't) class)
         for slot in (class-direct-slots class)
         for slot-name = (slot-definition-name slot)
         for layer = (find-layer-class (slot-definition-layer slot)) do
         (loop for layered-reader in (slot-definition-layered-readers slot)
               for gf = (ensure-layered-function layered-reader :lambda-list '(object))
               for method = (ensure-layered-method
                             layered-reader
                             `(lambda (object)
                                (declare (optimize (speed 3) (debug 0) (safety 0)
                                                   (compilation-speed 0)))
                                (slot-value object ',slot-name))
                             :in-layer layer
                             :specializers reader-specializers)
               do (push (cons gf method) (layered-accessor-methods slot)))
         (loop for layered-writer in (slot-definition-layered-writers slot)
               for gf = (ensure-layered-function layered-writer
                                                 :lambda-list '(new-value object)
                                                 :argument-precedence-order '(object new-value))
               for method = (ensure-layered-method
                             layered-writer
                             `(lambda (new-value object)
                                (declare (optimize (speed 3) (debug 0) (safety 0)
                                                   (compilation-speed 0)))
                                (setf (slot-value object ',slot-name)
                                      new-value))
                             :in-layer layer
                             :specializers writer-specializers)
               do (push (cons gf method) (layered-accessor-methods slot))))))

(defgeneric remove-layered-accessors (class)
  (:method ((class layered-access-class))
   (loop for slot in (class-direct-slots class)
         do (loop for method in (layered-accessor-methods slot)
                  do (remove-method (car method) (cdr method))))))

(defmethod initialize-instance :after
  ((class layered-access-class) &key)
  (add-layered-accessors class))

(defmethod reinitialize-instance :around
  ((class layered-access-class)
   &key (direct-slots () direct-slots-p))
  (declare (ignore direct-slots))
  (if direct-slots-p
    (progn
      (remove-layered-accessors class)
      (call-next-method)
      (add-layered-accessors class)
      class)
    (call-next-method)))

APT Browse - Built by Thomas Orozco.