File: cx-layer-metaclasses.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 (149 lines) | stat: -rw-r--r-- 5,875 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
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
(in-package :contextl)

(defclass standard-layer-object (special-object)
  ())

(defgeneric layer-name (layer)
  (:method ((layer symbol)) layer)
  (:method ((layer (eql (find-class 't)))) 't)
  (:method ((layer standard-layer-object)) (layer-name (class-of layer))))

(defclass standard-layer-class (special-class singleton-class)
  ((layer-name :initarg original-name
               :initform nil
               :reader layer-name)))

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

(defmethod print-object ((object standard-layer-object) stream)
  (print-unreadable-object (object stream :type nil :identity t)
    (format stream "LAYER ~A" (layer-name object))))

(defmethod print-object ((object standard-layer-class) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (princ (layer-name object) stream)))

(defmethod initialize-instance :around
  ((class standard-layer-class) &rest initargs &key direct-superclasses)
  (declare (dynamic-extent initargs))
  (if (loop for direct-superclass in direct-superclasses
            thereis (ignore-errors (subtypep direct-superclass 'standard-layer-object)))
    (call-next-method)
    (apply #'call-next-method
           class
           :direct-superclasses
           (append direct-superclasses
                   (list (find-class 'standard-layer-object)))
           initargs)))

(defmethod reinitialize-instance :around
  ((class standard-layer-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
  (declare (dynamic-extent initargs))
  (if (or (not direct-superclasses-p)
          (loop for direct-superclass in direct-superclasses
                thereis (ignore-errors (subtypep direct-superclass 'standard-layer-object))))
    (call-next-method)
    (apply #'call-next-method
           class
           :direct-superclasses
           (append direct-superclasses
                   (list (find-class 'standard-layer-object)))
           initargs)))

(defclass layer-direct-slot-definition (singleton-direct-slot-definition
                                        special-direct-slot-definition)
  ())

(defmethod direct-slot-definition-class ((class standard-layer-class) &key)
  (find-class 'layer-direct-slot-definition))

(defmacro deflayer (name &optional superlayers &body options)
  (destructuring-bind (&optional slots &rest options) options
    `(defclass ,(defining-layer name) ,(mapcar #'defining-layer superlayers)
       ,(if slots slots '())
       ,@options
       ,@(unless (assoc :metaclass options)
           '((:metaclass standard-layer-class)))
       (original-name . ,name))))

(defun ensure-layer (layer-name
                     &rest initargs
                     &key (metaclass 'standard-layer-class)
                     &allow-other-keys)
  (declare (dynamic-extent initargs))
  (apply #'ensure-class
         (defining-layer layer-name)
         :metaclass metaclass
         'original-name layer-name
         initargs))

(defgeneric find-layer-class (layer &optional errorp environment)
  (:method ((layer (eql 't)) &optional errorp environment)
   (declare (ignore errorp environment))
   (load-time-value (find-class 't)))
  (:method ((layer (eql (find-class 't))) &optional errorp environment)
   (declare (ignore errorp environment))
   (load-time-value (find-class 't)))
  (:method ((layer symbol) &optional (errorp t) environment)
   (or (find-class (defining-layer layer) nil environment)
       (when errorp
         (cerror "Retry finding the layer."
                 "There is no layer named ~S." layer)
         (find-layer-class layer errorp environment))))
  (:method ((layer standard-layer-object) &optional errorp environment)
   (declare (ignore errorp environment))
   (class-of layer))
  (:method ((layer standard-layer-class) &optional errorp environment)
   (declare (ignore errorp environment))
   layer))

(defgeneric find-layer (layer &optional errorp environment)
  (:method ((layer (eql 't)) &optional errorp environment)
   (declare (ignore errorp environment))
   't)
  (:method ((layer (eql (find-class 't))) &optional errorp environment)
   (declare (ignore errorp environment))
   't)
  (:method ((layer symbol) &optional (errorp t) environment)
   (let ((layer-class (find-layer-class layer errorp environment)))
     (when layer-class
       #-lispworks (ensure-finalized layer-class)
       (class-prototype layer-class))))
  (:method ((layer standard-layer-object) &optional errorp environment)
   (declare (ignore errorp environment))
   layer)
  (:method ((layer standard-layer-class) &optional errorp environment)
   (declare (ignore errorp environment))
   #-lispworks (ensure-finalized layer)
   (class-prototype layer)))

(defgeneric layer-makunbound (layer)
  (:method ((layer symbol))
   (let* ((defining-layer (defining-layer layer))
          (class (find-class defining-layer)))
     (setf (find-class defining-layer) nil
           (class-name class) nil)))
  (:method ((layer standard-layer-object))
   (let* ((class-name (class-name (class-of layer)))
          (class (find-class class-name)))
     (setf (find-class class-name) nil
           (class-name class) nil)))
  (:method ((layer standard-layer-class))
   (let* ((class-name (class-name layer))
          (class (find-class class-name)))
     (setf (find-class class-name) nil
           (class-name class) nil))))

(defstruct layer-context
  (prototype (error "No layer-context-prototype specified.")
             :type standard-object
             :read-only t)
  (specializer (error "No layer-context-specializer specified.")
               :type standard-layer-class
               :read-only t)
  (children/ensure-active '() :type list)
  (children/ensure-inactive '() :type list)
  (lock (make-recursive-lock :name "layer context") :read-only t))