File: cx-class-in-layer.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 (75 lines) | stat: -rw-r--r-- 2,769 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
(in-package :contextl)

(defgeneric class-layer (class)
  (:method ((class class)) 't))

(defclass standard-class-in-layer (standard-class)
  ((layer :initarg :in-layer
          :initarg :in
          :initform 't
          :reader class-layer)))

(defmethod validate-superclass
           ((class standard-class-in-layer)
            (superclass standard-class))
  t)

(defgeneric slot-definition-layer (slot)
  (:method ((slot direct-slot-definition)) 't))

(defclass standard-direct-slot-definition-in-layer (standard-direct-slot-definition)
  ((layer :initarg :in-layer
          :initarg :in
          :initform 't
          :reader slot-definition-layer)))

(defmethod direct-slot-definition-class
           ((class standard-class-in-layer) &key &allow-other-keys)
  (find-class 'standard-direct-slot-definition-in-layer))

(defgeneric slot-definition-layers (slot)
  (:method ((slot effective-slot-definition)) '(t)))

(defclass standard-effective-slot-definition-in-layers (standard-effective-slot-definition)
  ((layers :initform '(t)
           :reader slot-definition-layers)))

(defmethod effective-slot-definition-class
           ((class standard-class-in-layer) &key &allow-other-keys)
  (find-class 'standard-effective-slot-definition-in-layers))

(defmethod compute-effective-slot-definition
           ((class standard-class-in-layer) name direct-slot-definitions)
  (declare (ignore name))
  (let ((slot (call-next-method)))
    (setf (slot-value slot 'layers)
          (loop for direct-slot in direct-slot-definitions
                for layers = (list (layer-name (slot-definition-layer direct-slot)))
                then (adjoin (layer-name (slot-definition-layer direct-slot)) layers
                             :test #'eq)
                finally (return layers)))
    slot))

(defmethod initialize-instance :around
  ((class standard-class-in-layer) &rest initargs
   &key (direct-slots ()) (in-layer 't))
  (declare (dynamic-extent initargs))
  (apply #'call-next-method class
         :direct-slots
         (loop for direct-slot in direct-slots
               if (get-properties direct-slot '(:in-layer :in)) collect direct-slot
               else collect (list* :in-layer in-layer direct-slot))
         initargs))

(defmethod reinitialize-instance :around
  ((class standard-class-in-layer) &rest initargs
   &key (direct-slots () direct-slots-p) (in-layer 't))
  (declare (dynamic-extent initargs))
  (if direct-slots-p
    (apply #'call-next-method class
           :direct-slots
           (loop for direct-slot in direct-slots
                 if (get-properties direct-slot '(:in-layer :in)) collect direct-slot
                 else collect (list* :in-layer in-layer direct-slot))
           initargs)
    (call-next-method)))